home *** CD-ROM | disk | FTP | other *** search
/ Developer CD Series 1995 February: Tool Chest / Dev.CD Feb 95 / Dev.CD Feb 95.toast / Tool Chest / Development Tools & Languages / Dylan Related / Mindy-1.1 (sources only) / mindy-1.1 / comp / expand.c < prev    next >
Encoding:
C/C++ Source or Header  |  1994-08-19  |  74.6 KB  |  2,720 lines  |  [TEXT/ttxt]
  1. /**********************************************************************\
  2. *
  3. *  Copyright (c) 1994  Carnegie Mellon University
  4. *  All rights reserved.
  5. *  
  6. *  Use and copying of this software and preparation of derivative
  7. *  works based on this software are permitted, including commercial
  8. *  use, provided that the following conditions are observed:
  9. *  
  10. *  1. This copyright notice must be retained in full on any copies
  11. *     and on appropriate parts of any derivative works.
  12. *  2. Documentation (paper or online) accompanying any system that
  13. *     incorporates this software, or any part of it, must acknowledge
  14. *     the contribution of the Gwydion Project at Carnegie Mellon
  15. *     University.
  16. *  
  17. *  This software is made available "as is".  Neither the authors nor
  18. *  Carnegie Mellon University make any warranty about the software,
  19. *  its performance, or its conformity to any specification.
  20. *  
  21. *  Bug reports, questions, comments, and suggestions should be sent by
  22. *  E-mail to the Internet address "gwydion-bugs@cs.cmu.edu".
  23. *
  24. ***********************************************************************
  25. *
  26. * $Header: expand.c,v 1.19 94/08/18 21:35:40 wlott Exp $
  27. *
  28. * This file does source-to-source expansions.
  29. *
  30. \**********************************************************************/
  31.  
  32. #include <stdio.h>
  33. #include <string.h>
  34.  
  35. #include "mindycomp.h"
  36. #include "src.h"
  37. #include "literal.h"
  38. #include "dup.h"
  39. #include "free.h"
  40. #include "sym.h"
  41. #include "expand.h"
  42. #include "info.h"
  43. #include "lose.h"
  44.  
  45. static void expand_expr(struct expr **ptr);
  46. static void expand_body(struct body *body, boolean top_level);
  47.  
  48.  
  49. /* Utilities */
  50.  
  51. static struct body *chain_bodies(struct body *body1, struct body *body2)
  52. {
  53.     if (body1->head == NULL) {
  54.     free(body1);
  55.     return body2;
  56.     }
  57.     else {
  58.     if (body2->head != NULL) {
  59.         *body1->tail = body2->head;
  60.         body1->tail = body2->tail;
  61.     }
  62.     free(body2);
  63.     return body1;
  64.     }
  65. }
  66.  
  67. static void bind_params(struct body *body, struct param_list *vars,
  68.             struct expr *expr)
  69. {
  70.     add_constituent(body, make_let(make_bindings(vars, expr)));
  71. }
  72.  
  73. static void bind_param(struct body *body, struct param *var, struct expr *expr)
  74. {
  75.     bind_params(body, push_param(var, make_param_list()), expr);
  76. }
  77.  
  78. static void bind_temp(struct body *body, struct id *id, struct expr *expr)
  79. {
  80.     bind_param(body, make_param(id, NULL), expr);
  81. }
  82.  
  83. static void add_expr(struct body *body, struct expr *expr)
  84. {
  85.     add_constituent(body, make_expr_constituent(expr));
  86. }
  87.  
  88. static void expand_param_list(struct param_list *params)
  89. {
  90.     struct param *p;
  91.     struct keyword_param *k;
  92.  
  93.     for (p = params->required_params; p != NULL; p = p->next)
  94.     if (p->type)
  95.         expand_expr(&p->type);
  96.     for (k = params->keyword_params; k != NULL; k = k->next) {
  97.     if (k->type)
  98.         expand_expr(&k->type);
  99.     if (k->def)
  100.         expand_expr(&k->def);
  101.     }
  102. }
  103.  
  104. static void expand_bindings(struct bindings *bindings)
  105. {
  106.     expand_param_list(bindings->params);
  107.     expand_expr(&bindings->expr);
  108. }
  109.  
  110. static void expand_rettypes(struct return_type_list *rettypes)
  111. {
  112.     struct return_type *r;
  113.  
  114.     for (r = rettypes->req_types; r != NULL; r = r->next)
  115.     if (r->type)
  116.         expand_expr(&r->type);
  117.     if (rettypes->rest_type)
  118.     expand_expr(&rettypes->rest_type);
  119. }
  120.  
  121. static void bind_rettypes(struct body *body,
  122.               struct return_type_list *rettypes)
  123. {
  124.     struct return_type *r;
  125.     struct arglist *list_args = make_argument_list();
  126.     struct symbol *ctype = sym_CheckType;
  127.     struct symbol *type_class = sym_Type;
  128.     struct symbol *object = sym_Object;
  129.  
  130.     for (r = rettypes->req_types; r != NULL; r = r->next) {
  131.     if (r->type) {
  132.         struct arglist *args = make_argument_list();
  133.         struct expr *type;
  134.  
  135.         add_argument(args, make_argument(r->type));
  136.         r->type = NULL;
  137.         add_argument(args, make_argument(make_varref(id(type_class))));
  138.         type = make_function_call(make_varref(id(ctype)), args);
  139.         r->temp = gensym();
  140.         bind_temp(body, id(r->temp), type);
  141.         add_argument(list_args,make_argument(make_varref(id(r->temp))));
  142.     }
  143.     else
  144.         add_argument(list_args, make_argument(make_varref(id(object))));
  145.     }
  146.     rettypes->req_types_list
  147.     = make_function_call(make_varref(id(sym_List)), list_args);
  148.  
  149.     if (rettypes->rest_type) {
  150.     struct arglist *args = make_argument_list();
  151.     add_argument(args, make_argument(rettypes->rest_type));
  152.     rettypes->rest_type = NULL;
  153.     add_argument(args, make_argument(make_varref(id(type_class))));
  154.     rettypes->rest_temp = gensym();
  155.     bind_temp(body, id(rettypes->rest_temp),
  156.           make_function_call(make_varref(id(ctype)), args));
  157.     rettypes->rest_temp_varref = make_varref(id(rettypes->rest_temp));
  158.     }
  159. }
  160.  
  161. static void expand_plist(struct plist *plist)
  162. {
  163.     if (plist) {
  164.     struct property *p;
  165.  
  166.     for (p = plist->head; p != NULL; p = p->next)
  167.         expand_expr(&p->expr);
  168.     }
  169. }
  170.  
  171. static void add_plist_arguments(struct arglist *args, struct plist *plist)
  172. {
  173.     struct property *prop, *next;
  174.  
  175.     for (prop = plist->head; prop != NULL; prop = next) {
  176.     struct literal *key = make_symbol_literal(prop->keyword);
  177.     add_argument(args, make_argument(make_literal_ref(key)));
  178.     add_argument(args, make_argument(prop->expr));
  179.     next = prop->next;
  180.     free(prop);
  181.     }
  182.     free(plist);
  183. }
  184.  
  185. static void change_to_setter(struct id *id)
  186. {
  187.     static char buf[256];
  188.     char *ptr;
  189.     struct symbol *sym = id->symbol;
  190.     int len = strlen(sym->name);
  191.  
  192.     if (len + 8 > sizeof(buf))
  193.     ptr = malloc(len + 8);
  194.     else
  195.     ptr = buf;
  196.  
  197.     strcpy(ptr, sym->name);
  198.     strcpy(ptr+len, "-setter");
  199.  
  200.     id->symbol = symbol(ptr);
  201.  
  202.     if (ptr != buf)
  203.     free(ptr);
  204. }
  205.  
  206. static struct argument *make_find_var_arg(struct id *var)
  207. {
  208.     struct arglist *args = make_argument_list();
  209.     struct expr *expr;
  210.  
  211.     add_argument(args, make_argument(make_varref(dup_id(var))));
  212.     expr = make_function_call(make_varref(id(sym_FindVariable)), args);
  213.  
  214.     return make_argument(expr);
  215. }
  216.  
  217.  
  218. /* Method expander */
  219.  
  220. static void add_method_wrap(struct body *body, struct method *method)
  221. {
  222.     struct param_list *params = method->params;
  223.     struct param *p;
  224.     struct keyword_param *k;
  225.     struct arglist *list_args = make_argument_list();
  226.     struct symbol *ctype = sym_CheckType;
  227.     struct symbol *type_class = sym_Type;
  228.  
  229.     if (ParseOnly)
  230.     lose("Adding method wrap when ParseOnly is true?");
  231.  
  232.     for (p = params->required_params; p != NULL; p = p->next) {
  233.     if (p->type) {
  234.         struct arglist *args = make_argument_list();
  235.         struct expr *expr;
  236.  
  237.         p->type_temp = gensym();
  238.         add_argument(args, make_argument(p->type));
  239.         add_argument(args, make_argument(make_varref(id(type_class))));
  240.         expr = make_function_call(make_varref(id(ctype)), args);
  241.         bind_temp(body, id(p->type_temp), expr);
  242.         p->type = NULL;
  243.         expr = make_varref(id(p->type_temp));
  244.         add_argument(list_args, make_argument(expr));
  245.     }
  246.     else {
  247.         struct expr *expr = make_varref(id(sym_Object));
  248.         add_argument(list_args, make_argument(expr));
  249.     }
  250.     }
  251.     method->specializers
  252.     = make_function_call(make_varref(id(sym_List)), list_args);
  253.  
  254.     for (k = params->keyword_params; k != NULL; k = k->next) {
  255.     if (k->type) {
  256.         struct arglist *args = make_argument_list();
  257.         struct expr *expr;
  258.  
  259.         k->type_temp = gensym();
  260.         add_argument(args, make_argument(k->type));
  261.         add_argument(args, make_argument(make_varref(id(type_class))));
  262.         expr = make_function_call(make_varref(id(ctype)), args);
  263.         bind_temp(body, id(k->type_temp), expr);
  264.         k->type = NULL;
  265.     }
  266.     }
  267.  
  268.     if (method->rettypes)
  269.     bind_rettypes(body, method->rettypes);
  270. }
  271.  
  272. static void bind_next_param(struct body *body, struct param_list *params)
  273. {
  274.     struct symbol *temp = gensym();
  275.     struct arglist *args;
  276.     struct expr *expr;
  277.     struct param *p;
  278.  
  279.     /* Make sure there is a #rest parameter if there are #key params. */
  280.     if (params->allow_keys && params->rest_param == NULL)
  281.     params->rest_param = id(gensym());
  282.  
  283.     /* Build the argument list for the call to make-next-method-function */
  284.     args = make_argument_list();
  285.     expr = make_varref(id(sym_MakeNextMethodFunction));
  286.  
  287.     /* If there is a #rest param, we are going to be calling apply */
  288.     if (params->rest_param)
  289.     add_argument(args, make_argument(expr));
  290.  
  291.     /* Pass the list of next methods as the first argument. */
  292.     add_argument(args, make_argument(make_varref(id(temp))));
  293.  
  294.     /* Pass all the required params. */
  295.     for (p = params->required_params; p != NULL; p = p->next)
  296.     add_argument(args, make_argument(make_varref(dup_id(p->id))));
  297.  
  298.     if (params->rest_param) {
  299.     /* Pass the rest param, and call apply. */
  300.     add_argument(args,
  301.              make_argument(make_varref(dup_id(params->rest_param))));
  302.     expr = make_function_call(make_varref(id(sym_Apply)), args);
  303.     }
  304.     else
  305.     /* Just call make-next-method-function */
  306.     expr = make_function_call(expr, args);
  307.  
  308.     /* Bind the original next_param to the results of make-next-method-fun */
  309.     bind_temp(body, params->next_param, expr);
  310.  
  311.     /* Change the next_param to the temp. */
  312.     params->next_param = id(temp);
  313. }
  314.  
  315. static void hairy_keyword(struct body *body, struct keyword_param *k)
  316. {
  317.     struct symbol *temp = gensym();
  318.     struct param *p = make_param(k->id, NULL);
  319.     int line = k->id->line;
  320.     struct arglist *args;
  321.     struct id *name;
  322.     struct expr *expr;
  323.  
  324.     name = id(temp);
  325.     name->line = line;
  326.     expr = make_varref(name);
  327.  
  328.     if (k->def) {
  329.     /* Bind the original id to:
  330.      *   if (temp == #unbound) default-expression else temp end
  331.      */
  332.     args = make_argument_list();
  333.     add_argument(args, make_argument(expr));
  334.     expr = make_literal_ref(make_unbound_literal());
  335.     add_argument(args, make_argument(expr));
  336.     expr = make_function_call(make_varref(id(sym_Eq)), args);
  337.     expr = make_if(expr, make_expr_body(k->def),
  338.                make_else(0, make_expr_body(make_varref(id(temp)))));
  339.     k->def = make_literal_ref(make_unbound_literal());
  340.     }
  341.  
  342.     if (k->type_temp) {
  343.     /* Wrap it with a call to check-type if it is typed. */
  344.     args = make_argument_list();
  345.     add_argument(args, make_argument(expr));
  346.     add_argument(args, make_argument(make_varref(id(k->type_temp))));
  347.     expr = make_function_call(make_varref(id(sym_CheckType)), args);
  348.     p->type_temp = k->type_temp;
  349.     }
  350.  
  351.     bind_param(body, p, expr);
  352.     
  353.     /* Change the keyword id to the temp. */
  354.     k->id = id(temp);
  355.     k->id->line = line;
  356. }
  357.  
  358. static struct body
  359.     *check_rettypes(struct body *form, struct return_type_list *rettypes)
  360. {
  361.     struct param_list *params = make_param_list();
  362.     struct param **param_tail = ¶ms->required_params;
  363.     struct return_type *r;
  364.     struct arglist *values = make_argument_list();
  365.     struct expr *fn;
  366.     struct symbol *ctype = sym_CheckType;
  367.  
  368.     r = rettypes->req_types;
  369.  
  370.     if (rettypes->restp) {
  371.     if (r == NULL && rettypes->rest_temp == NULL)
  372.         /* #rest <object> -- real easy to test. */
  373.         return form;
  374.     add_argument(values, make_argument(make_varref(id(sym_Values))));
  375.     }
  376.     else {
  377.     if (r == NULL) {
  378.         /* No results are returned -- hence it is easy to test their */
  379.         /* types. */
  380.         struct expr *expr = make_varref(id(sym_Values));
  381.         add_expr(form, make_function_call(expr, make_argument_list()));
  382.         return form;
  383.     }
  384.     else if (r->next == NULL) {
  385.         /* Only a single value is returned. */
  386.         struct arglist *args = make_argument_list();
  387.         struct body *body = make_body();
  388.         struct expr *expr;
  389.  
  390.         add_argument(args, make_argument(make_body_expr(form)));
  391.         if (r->temp) {
  392.         add_argument(args, make_argument(make_varref(id(r->temp))));
  393.         expr = make_varref(id(ctype));
  394.         }
  395.         else
  396.         expr = make_varref(id(sym_Values));
  397.         add_expr(body, make_function_call(expr, args));
  398.         return body;
  399.     }
  400.     }
  401.  
  402.     for (; r != NULL; r = r->next) {
  403.     struct symbol *temp = gensym();
  404.     struct param *param = make_param(id(temp), NULL);
  405.     struct expr *expr = make_varref(id(temp));
  406.     *param_tail = param;
  407.     param_tail = ¶m->next;
  408.     if (r->temp) {
  409.         struct arglist *args = make_argument_list();
  410.         add_argument(args, make_argument(expr));
  411.         add_argument(args, make_argument(make_varref(id(r->temp))));
  412.         expr = make_function_call(make_varref(id(ctype)), args);
  413.     }
  414.     add_argument(values, make_argument(expr));
  415.     }
  416.  
  417.     if (rettypes->restp) {
  418.     struct symbol *rest_temp = gensym();
  419.  
  420.     set_rest_param(params, id(rest_temp));
  421.     
  422.     if (rettypes->rest_temp) {
  423.         struct symbol *val_temp = gensym();
  424.         struct param_list *meth_params;
  425.         struct arglist *args;
  426.         struct body *body;
  427.         struct method *method;
  428.         struct expr *expr;
  429.  
  430.         args = make_argument_list();
  431.         add_argument(args, make_argument(make_varref(id(val_temp))));
  432.         add_argument(args,
  433.              make_argument(make_varref(id(rettypes->rest_temp))));
  434.         expr = make_function_call(make_varref(id(ctype)), args);
  435.         add_expr(body = make_body(), expr);
  436.     
  437.         meth_params = make_param_list();
  438.         meth_params = push_param(make_param(id(val_temp), NULL),
  439.                      meth_params);
  440.         method = make_method_description(meth_params, NULL, body);
  441.  
  442.         args = make_argument_list();
  443.         add_argument(args, make_argument(make_method_ref(method)));
  444.         add_argument(args, make_argument(make_varref(id(rest_temp))));
  445.         expr = make_function_call(make_varref(id(sym_Do)), args);
  446.  
  447.         add_expr(body = make_body(), expr);
  448.         add_expr(body, make_varref(id(rest_temp)));
  449.  
  450.         add_argument(values, make_argument(make_body_expr(body)));
  451.     }
  452.     else
  453.         add_argument(values, make_argument(make_varref(id(rest_temp))));
  454.  
  455.     fn = make_varref(id(sym_Apply));
  456.     }
  457.     else
  458.     fn = make_varref(id(sym_Values));
  459.  
  460.     {
  461.     struct body *body = make_body();
  462.     struct bindings *bind = make_bindings(params, make_body_expr(form));
  463.     add_constituent(body, make_let(bind));
  464.     add_expr(body, make_function_call(fn, values));
  465.     return body;
  466.     }
  467. }
  468.  
  469. static void expand_method_for_compile(struct method *method)
  470. {
  471.     struct param_list *params = method->params;
  472.     struct keyword_param *k;
  473.     struct body *body = make_body();
  474.  
  475.     if (params->next_param)
  476.     bind_next_param(body, method->params);
  477.  
  478.     for (k = params->keyword_params; k != NULL; k = k->next)
  479.     if ((k->def && k->def->kind != expr_LITERAL) || k->type_temp)
  480.         hairy_keyword(body, k);
  481.  
  482.     expand_param_list(params);
  483.  
  484.     if (method->rettypes)
  485.     method->body = check_rettypes(method->body, method->rettypes);
  486.  
  487.     method->body = chain_bodies(body, method->body);
  488.  
  489.     expand_body(method->body, FALSE);
  490. }
  491.  
  492. static void expand_method_for_parse(struct method *method)
  493. {
  494.     expand_param_list(method->params);
  495.     if (method->rettypes)
  496.     expand_rettypes(method->rettypes);
  497.     expand_body(method->body, FALSE);
  498. }
  499.  
  500.  
  501. /* defvar/defconst initializer generation. */
  502.  
  503. static struct method *make_initializer(char *kind, struct bindings *bindings)
  504. {
  505.     struct param_list *params = bindings->params;
  506.     struct param *param;
  507.     struct symbol *init = sym_InitVariable;
  508.     struct symbol *ctype = sym_CheckType;
  509.     struct symbol *type_class = sym_Type;
  510.     struct param_list *temps = make_param_list();
  511.     struct param **tail = &temps->required_params;
  512.     struct body *outer_body = make_body();
  513.     struct body *inner_body = make_body();
  514.     struct param *temp_param;
  515.     struct arglist *args, *init_args;
  516.     struct expr *expr;
  517.     struct symbol *type_temp, *temp;
  518.     int len;
  519.     char *debug_name;
  520.     struct method *res;
  521.     boolean first;
  522.  
  523.     len = strlen(kind) + 1 - strlen(", ");
  524.     for (param = params->required_params; param != NULL; param = param->next)
  525.     len += strlen(", ") + strlen(param->id->symbol->name);
  526.     if (params->rest_param)
  527.     len += strlen(", #rest ") + strlen(params->rest_param->symbol->name);
  528.     debug_name = malloc(len);
  529.     strcpy(debug_name, kind);
  530.  
  531.     first = TRUE;
  532.     for (param = params->required_params; param != NULL; param = param->next) {
  533.     if (first)
  534.         first = FALSE;
  535.     else
  536.         strcat(debug_name, ", ");
  537.     strcat(debug_name, param->id->symbol->name);
  538.  
  539.     temp = gensym();
  540.     temp_param = make_param(id(temp), NULL);
  541.     *tail = temp_param;
  542.     tail = &temp_param->next;
  543.  
  544.     if (param->type) {
  545.         type_temp = gensym();
  546.         args = make_argument_list();
  547.         add_argument(args, make_argument(param->type));
  548.         param->type = NULL;
  549.         add_argument(args, make_argument(make_varref(id(type_class))));
  550.         expr = make_function_call(make_varref(id(ctype)), args);
  551.         bind_temp(outer_body, id(type_temp), expr);
  552.     }
  553.     else
  554.         type_temp = NULL;
  555.     
  556.     init_args = make_argument_list();
  557.     add_argument(init_args, make_find_var_arg(param->id));
  558.     expr = make_varref(id(temp));
  559.     if (type_temp) {
  560.         args = make_argument_list();
  561.         add_argument(args, make_argument(expr));
  562.         add_argument(args, make_argument(make_varref(id(type_temp))));
  563.         expr = make_function_call(make_varref(id(ctype)), args);
  564.     }
  565.     add_argument(init_args, make_argument(expr));
  566.     if (type_temp)
  567.         add_argument(init_args, make_argument(make_varref(id(type_temp))));
  568.     else {
  569.         expr = make_literal_ref(make_false_literal());
  570.         add_argument(init_args, make_argument(expr));
  571.     }
  572.     add_expr(inner_body,
  573.          make_function_call(make_varref(id(init)), init_args));
  574.     }
  575.  
  576.     if (params->rest_param) {
  577.     if (first)
  578.         strcat(debug_name, "#rest ");
  579.     else
  580.         strcat(debug_name, ", #rest ");
  581.     strcat(debug_name, params->rest_param->symbol->name);
  582.     temp = gensym();
  583.     temps->rest_param = id(temp);
  584.     init_args = make_argument_list();
  585.     add_argument(init_args, make_find_var_arg(params->rest_param));
  586.     expr = make_varref(id(temp));
  587.     add_argument(init_args, make_argument(expr));
  588.     expr = make_literal_ref(make_false_literal());
  589.     add_argument(init_args, make_argument(expr));
  590.     add_expr(inner_body,
  591.          make_function_call(make_varref(id(init)), init_args));
  592.     }
  593.  
  594.     add_constituent(outer_body,
  595.             make_let(make_bindings(temps, bindings->expr)));
  596.     bindings->expr = NULL;
  597.  
  598.     outer_body = chain_bodies(outer_body, inner_body);
  599.  
  600.     add_expr(outer_body, make_literal_ref(make_false_literal()));
  601.     res = make_top_level_method(debug_name, outer_body);
  602.  
  603.     free(debug_name);
  604.  
  605.     return res;
  606. }
  607.  
  608.  
  609. /* define module and define library stuff. */
  610.  
  611. static struct literal *make_var_names_literal(struct variable_names *names)
  612. {
  613.     struct literal_list *guts = make_literal_list();
  614.     struct list_literal *res;
  615.     struct variable_name *name;
  616.  
  617.     for (name = names->head; name != NULL; name = name->next)
  618.     add_literal(guts, name->name);
  619.     res = (struct list_literal *)make_list_literal(guts);
  620.  
  621.     if (res->first) {
  622.     struct literal **prev, *cur, *scan;
  623.  
  624.     prev = &res->first->next;
  625.     while ((cur = *prev) != NULL) {
  626.         for (scan = res->first;
  627.          scan != cur;
  628.          scan = scan->next)
  629.         if (((struct symbol_literal *)cur)->symbol
  630.             == ((struct symbol_literal *)scan)->symbol)
  631.             break;
  632.         if (cur == scan)
  633.         prev = &cur->next;
  634.         else {
  635.         *prev = cur->next;
  636.         free(cur);
  637.         }
  638.     }
  639.     }
  640.  
  641.     return (struct literal *)res;
  642. }
  643.  
  644. static void expand_useopt_prefix(struct use_clause *use,
  645.                  struct prefix_option *option)
  646. {
  647.     use->prefix = option->prefix;
  648. }
  649.  
  650. static void expand_useopt_import(struct use_clause *use,
  651.                  struct import_option *option)
  652. {
  653.     use->import = make_var_names_literal(option->vars);
  654.  
  655.     if (option->renames->head != NULL) {
  656.     struct literal_list *guts = make_literal_list();
  657.     struct renaming *renaming;
  658.  
  659.     for (renaming = option->renames->head;
  660.          renaming != NULL;
  661.          renaming = renaming->next) {
  662.         struct literal_list *list = make_literal_list();
  663.         add_literal(list, renaming->from);
  664.         add_literal(guts, make_dotted_list_literal(list, renaming->to));
  665.     }
  666.     if (use->rename)
  667.         use->rename = make_dotted_list_literal(guts, use->rename);
  668.     else
  669.         use->rename = make_list_literal(guts);
  670.     }
  671. }
  672.  
  673. static void expand_useopt_exclude(struct use_clause *use,
  674.                   struct exclude_option *option)
  675. {
  676.     use->exclude = make_var_names_literal(option->vars);
  677. }
  678.  
  679. static void expand_useopt_rename(struct use_clause *use,
  680.                  struct rename_option *option)
  681. {
  682.     struct literal_list *guts = make_literal_list();
  683.     struct renaming *renaming;
  684.  
  685.     for (renaming = option->renames->head;
  686.      renaming != NULL;
  687.      renaming = renaming->next)
  688.     add_literal(guts,
  689.             make_dotted_list_literal(add_literal(make_literal_list(),
  690.                              renaming->from),
  691.                          renaming->to));
  692.     if (use->rename)
  693.     use->rename = make_dotted_list_literal(guts, use->rename);
  694.     else
  695.     use->rename = make_list_literal(guts);
  696. }
  697.  
  698. static void expand_useopt_export(struct use_clause *use,
  699.                  struct export_option *option)
  700. {
  701.     use->export = make_var_names_literal(option->vars);
  702. }
  703.  
  704. static void expand_useopt_import_all(struct use_clause *use,
  705.                      struct use_option *option)
  706. {
  707.     use->import = make_true_literal();
  708. }
  709.  
  710. static void expand_useopt_export_all(struct use_clause *use,
  711.                      struct use_option *option)
  712. {
  713.     use->export = make_true_literal();
  714. }
  715.  
  716. static void (*UseOptionExpanders[])() = {
  717.     expand_useopt_prefix, expand_useopt_import, expand_useopt_exclude,
  718.     expand_useopt_rename, expand_useopt_export,
  719.     expand_useopt_import_all, expand_useopt_export_all
  720. };
  721.  
  722. static void expand_use_clause(struct use_clause *use)
  723. {
  724.     struct use_option *option, *next;
  725.  
  726.     for (option = use->options; option != NULL; option = next) {
  727.     (*UseOptionExpanders[(int)option->kind])(use, option);
  728.     next = option->next;
  729.     free(option);
  730.     }
  731.     use->options = NULL;
  732.     if (use->import == NULL)
  733.     use->import = make_true_literal();
  734.     if (use->exclude == NULL)
  735.     use->exclude = make_list_literal(make_literal_list());
  736.     if (use->prefix == NULL)
  737.     use->prefix = make_false_literal();
  738.     if (use->rename == NULL)
  739.     use->rename = make_list_literal(make_literal_list());
  740.     if (use->export == NULL)
  741.     use->export = make_list_literal(make_literal_list());
  742. }
  743.  
  744. static void expand_defnamespace(struct defnamespace_constituent *c)
  745. {
  746.     struct use_clause *use;
  747.  
  748.     for (use = c->use_clauses; use != NULL; use = use->next)
  749.     expand_use_clause(use);
  750.     c->exported_literal = make_var_names_literal(c->exported_variables);
  751.     c->exported_variables = NULL;
  752.     c->created_literal = make_var_names_literal(c->created_variables);
  753.     c->created_variables = NULL;
  754. }
  755.  
  756.  
  757. /* Constituent expanders. */
  758.  
  759. static void expand_defconst_for_parse(struct defconst_constituent *c)
  760. {
  761.     expand_bindings(c->bindings);
  762. }
  763.  
  764. static void expand_defconst_for_compile(struct defconst_constituent *c)
  765. {
  766.     c->tlf = make_initializer("Define Constant ", c->bindings);
  767.     expand_method_for_compile(c->tlf);
  768. }
  769.  
  770. static boolean expand_defconst_constituent(struct defconst_constituent **ptr,
  771.                        boolean top_level)
  772. {
  773.     if (ParseOnly)
  774.     expand_defconst_for_parse(*ptr);
  775.     else if (top_level)
  776.     expand_defconst_for_compile(*ptr);
  777.     else
  778.     error((*ptr)->line, "define constant not at top-level");
  779.     return FALSE;
  780. }
  781.  
  782. static void expand_defvar_for_parse(struct defvar_constituent *c)
  783. {
  784.     expand_bindings(c->bindings);
  785. }
  786.  
  787. static void expand_defvar_for_compile(struct defvar_constituent *c)
  788. {
  789.     c->tlf = make_initializer("Define Variable ", c->bindings);
  790.     expand_method_for_compile(c->tlf);
  791. }
  792.  
  793. static boolean expand_defvar_constituent(struct defvar_constituent **ptr,
  794.                      boolean top_level)
  795. {
  796.     if (ParseOnly)
  797.     expand_defvar_for_parse(*ptr);
  798.     else if (top_level)
  799.     expand_defvar_for_compile(*ptr);
  800.     else
  801.     error((*ptr)->line, "define variable not at top-level");
  802.     return FALSE;
  803. }
  804.  
  805. static void expand_defmethod_for_parse(struct defmethod_constituent *c)
  806. {
  807.     expand_method_for_parse(c->method);
  808. }
  809.  
  810. static void expand_defmethod_for_compile(struct defmethod_constituent *c)
  811. {
  812.     struct method *method = c->method;
  813.     char *name = method->name->symbol->name;
  814.     char *debug_name = malloc(strlen(name) + sizeof("Define Method "));
  815.     struct symbol *defmeth = sym_DefineMethod;
  816.     struct body *body;
  817.     struct arglist *args;
  818.     struct expr *expr;
  819.  
  820.     body = make_body();
  821.     add_method_wrap(body, method);
  822.     args = make_argument_list();
  823.     add_argument(args, make_find_var_arg(method->name));
  824.     add_argument(args, make_argument(make_method_ref(c->method)));
  825.     add_expr(body, make_function_call(make_varref(id(defmeth)), args));
  826.     expr = make_literal_ref(make_symbol_literal(method->name->symbol));
  827.     add_expr(body, expr);
  828.  
  829.     strcpy(debug_name, "Define Method ");
  830.     strcat(debug_name, name);
  831.  
  832.     c->tlf = make_top_level_method(debug_name, body);
  833.  
  834.     free(debug_name);
  835.  
  836.     expand_method_for_compile(c->tlf);
  837. }
  838.  
  839. static boolean expand_defmethod_constituent(struct defmethod_constituent **ptr,
  840.                         boolean top_level)
  841. {
  842.     if (ParseOnly)
  843.     expand_defmethod_for_parse(*ptr);
  844.     else if (top_level)
  845.     expand_defmethod_for_compile(*ptr);
  846.     else
  847.     error((*ptr)->method->line, "define method not at top-level");
  848.     return FALSE;
  849. }
  850.  
  851. static void expand_defgeneric_for_parse(struct defgeneric_constituent *c)
  852. {
  853.     expand_param_list(c->params);
  854.     if (c->rettypes)
  855.     expand_rettypes(c->rettypes);
  856.     expand_plist(c->plist);
  857. }
  858.  
  859. static void expand_defgeneric_for_compile(struct defgeneric_constituent *c)
  860. {
  861.     char *name = c->name->symbol->name;
  862.     char *debug_name = malloc(strlen(name) + sizeof("Define Generic "));
  863.     struct body *body = make_body();
  864.     struct arglist *init_args = make_argument_list();
  865.     struct expr *expr;
  866.  
  867.     strcpy(debug_name, "Define Generic ");
  868.     strcat(debug_name, name);
  869.  
  870.     add_argument(init_args, make_find_var_arg(c->name));
  871.  
  872.     {
  873.     struct arglist *list_args = make_argument_list();
  874.     struct param *p;
  875.  
  876.     for (p = c->params->required_params; p != NULL; p = p->next)
  877.         if (p->type) {
  878.         add_argument(list_args, make_argument(p->type));
  879.         p->type = NULL;
  880.         }
  881.         else {
  882.         expr = make_varref(id(sym_Object));
  883.         add_argument(list_args, make_argument(expr));
  884.         }
  885.     expr = make_function_call(make_varref(id(sym_List)), list_args);
  886.     add_argument(init_args, make_argument(expr));
  887.     }
  888.     
  889.     if (c->params->rest_param)
  890.     expr = make_literal_ref(make_true_literal());
  891.     else
  892.     expr = make_literal_ref(make_false_literal());
  893.     add_argument(init_args, make_argument(expr));
  894.  
  895.     if (c->params->allow_keys) {
  896.     struct arglist *list_args = make_argument_list();
  897.     struct keyword_param *k;
  898.  
  899.     for (k = c->params->keyword_params; k != NULL; k = k->next) {
  900.         expr = make_literal_ref(make_symbol_literal(k->keyword));
  901.         add_argument(list_args, make_argument(expr));
  902.     }
  903.     expr = make_function_call(make_varref(id(sym_List)), list_args);
  904.     add_argument(init_args, make_argument(expr));
  905.     }
  906.     else {
  907.     expr = make_literal_ref(make_false_literal());
  908.     add_argument(init_args, make_argument(expr));
  909.     }
  910.  
  911.     expr = make_literal_ref(c->params->all_keys
  912.                 ? make_true_literal()
  913.                 : make_false_literal());
  914.     add_argument(init_args, make_argument(expr));
  915.  
  916.     if (c->rettypes) {
  917.     bind_rettypes(body, c->rettypes);
  918.     add_argument(init_args, make_argument(c->rettypes->req_types_list));
  919.     if (c->rettypes->rest_temp)
  920.         expr = c->rettypes->rest_temp_varref;
  921.     else if (c->rettypes->restp)
  922.         expr = make_literal_ref(make_true_literal());
  923.     else
  924.         expr = make_literal_ref(make_false_literal());
  925.     add_argument(init_args, make_argument(expr));
  926.     }
  927.     else {
  928.     expr = make_literal_ref(make_list_literal(make_literal_list()));
  929.     add_argument(init_args, make_argument(expr));
  930.     expr = make_literal_ref(make_true_literal());
  931.     add_argument(init_args, make_argument(expr));
  932.     }
  933.     if (c->plist) {
  934.     add_plist_arguments(init_args, c->plist);
  935.     c->plist = NULL;
  936.     }
  937.  
  938.     expr = make_function_call(make_varref(id(sym_DefineGeneric)),
  939.                   init_args);
  940.     add_expr(body, expr);
  941.     add_expr(body, make_literal_ref(make_symbol_literal(c->name->symbol)));
  942.  
  943.     c->tlf = make_top_level_method(debug_name, body);
  944.  
  945.     free(debug_name);
  946.  
  947.     expand_method_for_compile(c->tlf);
  948. }
  949.  
  950. static boolean
  951.     expand_defgeneric_constituent(struct defgeneric_constituent **ptr,
  952.                   boolean top_level)
  953. {
  954.     if (ParseOnly)
  955.     expand_defgeneric_for_parse(*ptr);
  956.     else if (top_level)
  957.     expand_defgeneric_for_compile(*ptr);
  958.     else
  959.     error((*ptr)->name->line, "define generic not at top-level");
  960.     return FALSE;
  961. }
  962.  
  963. static void expand_defclass_for_parse(struct defclass_constituent *c)
  964. {
  965.     struct superclass *super;
  966.     struct slot_spec *slot;
  967.     struct initarg_spec *initarg;
  968.     struct inherited_spec *inherited;
  969.  
  970.     for (super = c->supers; super != NULL; super = super->next)
  971.     expand_expr(&super->expr);
  972.     for (slot = c->slots; slot != NULL; slot = slot->next) {
  973.     if (slot->type)
  974.         expand_expr(&slot->type);
  975.     expand_plist(slot->plist);
  976.     }
  977.     for (initarg = c->initargs; initarg != NULL; initarg = initarg->next)
  978.     expand_plist(initarg->plist);
  979.     for (inherited = c->inheriteds; inherited != NULL;
  980.      inherited = inherited->next)
  981.     expand_plist(inherited->plist);
  982. }
  983.  
  984. static void expand_slots(struct body *body,
  985.              struct arglist *defclass_args,
  986.              struct defclass_constituent *c)
  987. {
  988.     struct slot_spec *slot;
  989.     struct arglist *list_args = make_argument_list();
  990.     struct expr *expr;
  991.  
  992.     for (slot = c->slots; slot != NULL; slot = slot->next) {
  993.     struct arglist *slot_args;
  994.     boolean default_setter = TRUE;
  995.     
  996.     /* Extract the setter name, if there is one */
  997.     if (slot->plist) {
  998.         struct property *prop, **prev;
  999.         prev = &slot->plist->head;
  1000.         while ((prop = *prev) != NULL) {
  1001.         if (prop->keyword == sym_Setter) {
  1002.             if (prop->expr->kind == expr_LITERAL
  1003.             && ((struct literal_expr *) (prop->expr))
  1004.             ->lit->kind == literal_FALSE) {
  1005.             default_setter = FALSE;
  1006.             *prev = prop->next;
  1007.             free(prop);
  1008.             }
  1009.             else if (prop->expr->kind != expr_VARREF) {
  1010.             error(prop->line, "Bogus %s in slot %s",
  1011.                   prop->keyword->name,
  1012.                   slot->name->symbol->name);
  1013.             prev = &prop->next;
  1014.             }
  1015.             else {
  1016.             struct varref_expr *v = (void *) prop->expr;
  1017.             slot->setter = v->var;
  1018.             *prev = prop->next;
  1019.             free(prop);
  1020.             }
  1021.         }
  1022.         else
  1023.           prev = &prop->next;
  1024.         }
  1025.     }
  1026.     
  1027.     /* Bind the getter and setter names */
  1028.     slot->getter = slot->name;
  1029.     if (slot->setter == NULL && default_setter) {
  1030.         slot->setter = dup_id(slot->name);
  1031.         change_to_setter(slot->setter);
  1032.     }
  1033.     
  1034.     /* Make the call to %define-slot */
  1035.  
  1036.     slot_args = make_argument_list();
  1037.     add_argument(slot_args, make_find_var_arg(slot->getter));
  1038.     if (slot->setter)
  1039.       add_argument(slot_args, make_find_var_arg(slot->setter));
  1040.     else {
  1041.         expr = make_literal_ref(make_false_literal());
  1042.         add_argument(slot_args, make_argument(expr));
  1043.     }
  1044.     expr = make_varref(id(sym_DefineSlot));
  1045.     add_expr(body, make_function_call(expr, slot_args));
  1046.     
  1047.     /* Make the call to make-slot */
  1048.  
  1049.     slot_args = make_argument_list();
  1050.     
  1051.     /* First argument: the slot name */
  1052.     expr = make_literal_ref(make_symbol_literal(slot->name->symbol));
  1053.     add_argument(slot_args, make_argument(expr));
  1054.     
  1055.     /* Second argument: the allocation. */
  1056.     expr = make_literal_ref(make_integer_literal((int) slot->alloc));
  1057.     add_argument(slot_args, make_argument(expr));
  1058.     
  1059.     /* Third argument: the getter. */
  1060.     add_argument(slot_args, make_argument(make_varref(slot->getter)));
  1061.     
  1062.     /* Fourth argument: the setter */
  1063.     if (slot->setter == NULL)
  1064.       expr = make_literal_ref(make_false_literal());
  1065.     else
  1066.       expr = make_varref(slot->setter);
  1067.     add_argument(slot_args, make_argument(expr));
  1068.     
  1069.     /* Fifth argument: the type. */
  1070.     if (slot->type)
  1071.       add_argument(slot_args, make_argument(slot->type));
  1072.     else {
  1073.         expr = make_literal_ref(make_false_literal());
  1074.         add_argument(slot_args, make_argument(expr));
  1075.     }
  1076.     
  1077.     /* Sixth and on: the other properties. */
  1078.     if (slot->plist) {
  1079.         add_plist_arguments(slot_args, slot->plist);
  1080.         slot->plist = NULL;
  1081.     }
  1082.     
  1083.     expr = make_varref(id(sym_MakeSlot));
  1084.     expr = make_function_call(expr, slot_args);
  1085.     add_argument(list_args, make_argument(expr));
  1086.     }
  1087.     expr = make_function_call(make_varref(id(sym_List)), list_args);
  1088.     add_argument(defclass_args, make_argument(expr));
  1089. }
  1090.  
  1091. static void expand_initargs(struct body *body,
  1092.                 struct arglist *defclass_args,
  1093.                 struct defclass_constituent *c)
  1094. {
  1095.     struct initarg_spec *initarg;
  1096.     struct arglist *list_args = make_argument_list();
  1097.     struct expr *expr;
  1098.  
  1099.     for (initarg = c->initargs; initarg != NULL; initarg = initarg->next) {
  1100.     struct arglist *initarg_args = make_argument_list();
  1101.     
  1102.     /* Make the call to make-initarg */
  1103.     
  1104.     /* First argument: the slot name */
  1105.     expr = make_literal_ref(make_symbol_literal(initarg->keyword));
  1106.     add_argument(initarg_args, make_argument(expr));
  1107.     
  1108.     /* Second argument: required */
  1109.     if (initarg->required)
  1110.         expr = make_literal_ref(make_true_literal());
  1111.     else
  1112.         expr = make_literal_ref(make_false_literal());
  1113.     add_argument(initarg_args, make_argument(expr));
  1114.  
  1115.     /* Other arguments: properties */
  1116.     if (initarg->plist) {
  1117.         add_plist_arguments(initarg_args, initarg->plist);
  1118.         initarg->plist = NULL;
  1119.     }
  1120.     
  1121.     expr = make_varref(id(sym_MakeInitarg));
  1122.     expr = make_function_call(expr, initarg_args);
  1123.     add_argument(list_args, make_argument(expr));
  1124.     }
  1125.     expr = make_function_call(make_varref(id(sym_List)), list_args);
  1126.     add_argument(defclass_args, make_argument(expr));
  1127. }
  1128.  
  1129. static void expand_inheriteds(struct body *body,
  1130.                   struct arglist *defclass_args,
  1131.                   struct defclass_constituent *c)
  1132. {
  1133.     struct inherited_spec *inherited;
  1134.     struct arglist *list_args = make_argument_list();
  1135.     struct expr *expr;
  1136.  
  1137.     for (inherited = c->inheriteds; inherited != NULL;
  1138.      inherited = inherited->next) {
  1139.     struct arglist *inherited_args = make_argument_list();
  1140.     
  1141.     /* Make the call to make-inherited */
  1142.     
  1143.     /* First argument: the slot name */
  1144.     expr = make_literal_ref(make_symbol_literal(inherited->name->symbol));
  1145.     add_argument(inherited_args, make_argument(expr));
  1146.     
  1147.     /* Other arguments: properties */
  1148.     if (inherited->plist) {
  1149.         add_plist_arguments(inherited_args, inherited->plist);
  1150.         inherited->plist = NULL;
  1151.     }
  1152.     
  1153.     expr = make_varref(id(sym_MakeInherited));
  1154.     expr = make_function_call(expr, inherited_args);
  1155.     add_argument(list_args, make_argument(expr));
  1156.     }
  1157.     expr = make_function_call(make_varref(id(sym_List)), list_args);
  1158.     add_argument(defclass_args, make_argument(expr));
  1159. }
  1160.  
  1161. static void expand_defclass_for_compile(struct defclass_constituent *c)
  1162. {
  1163.     char *name = c->name->symbol->name;
  1164.     char *debug_name = malloc(strlen(name) + sizeof("Define Class "));
  1165.  
  1166.     strcpy(debug_name, "Define Class ");
  1167.     strcat(debug_name, name);
  1168.  
  1169.     /* Phase I: Create the class with its superclasses. */
  1170.  
  1171.     {
  1172.     struct arglist *list_args = make_argument_list();
  1173.     struct arglist *defclass_args = make_argument_list();
  1174.     struct body *body = make_body();
  1175.     struct superclass *super;
  1176.     struct expr *expr;
  1177.     
  1178.     add_argument(defclass_args, make_argument(make_varref(c->name)));
  1179.     for (super = c->supers; super != NULL; super = super->next)
  1180.         add_argument(list_args, make_argument(super->expr));
  1181.     expr = make_function_call(make_varref(id(sym_List)), list_args);
  1182.     add_argument(defclass_args, make_argument(expr));
  1183.  
  1184.     expr = make_varref(id(sym_DefineClass1));
  1185.     add_expr(body, make_function_call(expr, defclass_args));
  1186.     add_expr(body, make_literal_ref(make_symbol_literal(c->name->symbol)));
  1187.  
  1188.     c->tlf1 = make_top_level_method(debug_name, body);
  1189.     }
  1190.  
  1191.     /* Phase II: Create the slots, init args, and inherited slots. */
  1192.  
  1193.     {
  1194.     struct arglist *defclass_args = make_argument_list();
  1195.     struct body *body = make_body();
  1196.     struct expr *expr;
  1197.     
  1198.     add_argument(defclass_args, make_argument(make_varref(dup_id(c->name))));
  1199.  
  1200.     expand_slots(body, defclass_args, c);
  1201.     expand_initargs(body, defclass_args, c);
  1202.     expand_inheriteds(body, defclass_args, c);
  1203.  
  1204.     expr = make_varref(id(sym_DefineClass2));
  1205.     add_expr(body, make_function_call(expr, defclass_args));
  1206.     add_expr(body, make_literal_ref(make_symbol_literal(c->name->symbol)));
  1207.  
  1208.     c->tlf2 = make_top_level_method(debug_name, body);
  1209.     }
  1210.  
  1211.     free(debug_name);
  1212.  
  1213.     expand_method_for_compile(c->tlf1);
  1214.     expand_method_for_compile(c->tlf2);
  1215. }
  1216.  
  1217. static boolean expand_defclass_constituent(struct defclass_constituent **ptr,
  1218.                        boolean top_level)
  1219. {
  1220.     if (ParseOnly)
  1221.     expand_defclass_for_parse(*ptr);
  1222.     else if (top_level)
  1223.     expand_defclass_for_compile(*ptr);
  1224.     else
  1225.     error((*ptr)->name->line, "define class not at top-level");
  1226.     return FALSE;
  1227. }
  1228.  
  1229. static boolean expand_expr_constituent(struct constituent **ptr,
  1230.                        boolean top_level)
  1231. {
  1232.     struct expr_constituent *c = (struct expr_constituent *)*ptr;
  1233.     struct expr *expr = c->expr;
  1234.  
  1235.     if (top_level && !ParseOnly) {
  1236.     if (expr->kind == expr_BODY) {
  1237.         struct body_expr *body_expr = (struct body_expr *)expr;
  1238.         expand_body(body_expr->body, TRUE);
  1239.         return FALSE;
  1240.     }
  1241.     else {
  1242.         *ptr = make_top_level_form("Top Level Form",
  1243.                        (struct constituent *)c);
  1244.         return TRUE;
  1245.     }
  1246.     }
  1247.     else {
  1248.     expand_expr(&c->expr);
  1249.     return FALSE;
  1250.     }
  1251. }
  1252.  
  1253. static boolean expand_local_constituent(struct constituent **ptr,
  1254.                     boolean top_level)
  1255. {
  1256.     struct local_constituent *c = (struct local_constituent *)*ptr;
  1257.     struct method *method = c->methods;
  1258.  
  1259.     if (ParseOnly) {
  1260.     while (method != NULL) {
  1261.         expand_method_for_parse(method);
  1262.         method = method->next_local;
  1263.     }
  1264.     expand_body(c->body, FALSE);
  1265.     return FALSE;
  1266.     }
  1267.     else if (top_level) {
  1268.     *ptr = make_top_level_form("Top Level Form", (struct constituent *)c);
  1269.     return TRUE;
  1270.     }
  1271.     else if (method != NULL && method->specializers == NULL) {
  1272.     struct body *body = make_body();
  1273.     for (; method != NULL; method = method->next_local)
  1274.         add_method_wrap(body, method);
  1275.     add_constituent(body, (struct constituent *)c);
  1276.     *ptr = make_expr_constituent(make_body_expr(body));
  1277.     return TRUE;
  1278.     }
  1279.     else {
  1280.     for (; method != NULL; method = method->next_local)
  1281.         expand_method_for_compile(method);
  1282.     expand_body(c->body, FALSE);
  1283.     return FALSE;
  1284.     }
  1285. }
  1286.  
  1287. static boolean expand_handler_constituent(struct constituent **ptr,
  1288.                       boolean top_level)
  1289. {
  1290.     struct handler_constituent *h = (struct handler_constituent *)*ptr;
  1291.     struct body *body;
  1292.     struct arglist *args;
  1293.  
  1294.     if (top_level && !ParseOnly) {
  1295.     *ptr = make_top_level_form("Top Level Form", (struct constituent *)h);
  1296.     return TRUE;
  1297.     }
  1298.  
  1299.     body = make_body();
  1300.     args = make_argument_list();
  1301.  
  1302.     add_argument(args, make_argument(h->type));
  1303.     add_argument(args, make_argument(h->func));
  1304.     if (h->plist) {
  1305.     add_plist_arguments(args, h->plist);
  1306.     h->plist = NULL;
  1307.     }
  1308.     add_expr(body, make_function_call(make_varref(id(sym_PushHandler)),
  1309.                       args));
  1310.  
  1311.  
  1312.     /* Link the handler body into the body we have just made, and replace */
  1313.     /* the handler body with it. */
  1314.     h->body = chain_bodies(body, h->body);
  1315.  
  1316.     /* Clear out the type and func */
  1317.     h->type = NULL;
  1318.     h->func = NULL;
  1319.  
  1320.     /* Now expand that body. */
  1321.     expand_body(h->body, FALSE);
  1322.  
  1323.     return FALSE;
  1324. }
  1325.  
  1326. static boolean expand_let_constituent(struct constituent **ptr,
  1327.                       boolean top_level)
  1328. {
  1329.     struct let_constituent *let = (struct let_constituent *)*ptr;
  1330.     struct bindings *bindings = let->bindings;
  1331.  
  1332.     if (ParseOnly) {
  1333.     expand_bindings(bindings);
  1334.     expand_body(let->body, FALSE);
  1335.     return FALSE;
  1336.     }
  1337.     else if (top_level) {
  1338.     *ptr = make_top_level_form("Top Level Form",(struct constituent *)let);
  1339.     return TRUE;
  1340.     }
  1341.     else {
  1342.     struct param_list *params = bindings->params;
  1343.     struct body *body = NULL;
  1344.     struct param *p;
  1345.     struct arglist *args;
  1346.     struct expr *expr;
  1347.     struct symbol *check_type = sym_CheckType;
  1348.     struct symbol *type_class = sym_Type;
  1349.  
  1350.     for (p = params->required_params; p != NULL; p = p->next)
  1351.         if (p->type) {
  1352.         if (body == NULL)
  1353.             body = make_body();
  1354.         p->type_temp = gensym();
  1355.         args = make_argument_list();
  1356.         add_argument(args, make_argument(p->type));
  1357.         add_argument(args, make_argument(make_varref(id(type_class))));
  1358.         expr = make_function_call(make_varref(id(check_type)), args);
  1359.         bind_temp(body, id(p->type_temp), expr);
  1360.         p->type = NULL;
  1361.         }
  1362.     if (body != NULL) {
  1363.         p = params->required_params;
  1364.         if (p->next || params->rest_param) {
  1365.         /* There are multiple parameters, so we can't just wrap the */
  1366.         /* expression with check-type.  Therefore, we bind a bunch */
  1367.         /* of temps, and then bind the real variables to check-type */
  1368.         /* of the temps. */
  1369.         struct body *let_body = let->body;
  1370.         let->body = make_body();
  1371.         add_constituent(body, (struct constituent *)let);
  1372.         for (; p != NULL; p = p->next) {
  1373.             if (p->type_temp) {
  1374.             struct symbol *temp = gensym();
  1375.             struct param *new_param = make_param(p->id, NULL);
  1376.  
  1377.             p->id = id(temp);
  1378.             args = make_argument_list();
  1379.             add_argument(args,
  1380.                      make_argument(make_varref(id(temp))));
  1381.             expr = make_varref(id(p->type_temp));
  1382.             add_argument(args, make_argument(expr));
  1383.             expr = make_function_call(make_varref(id(check_type)),
  1384.                           args);
  1385.             bind_param(body, new_param, expr);
  1386.             }
  1387.         }
  1388.         add_expr(body, make_body_expr(let_body));
  1389.         }
  1390.         else {
  1391.         /* Wrap the expression with a call to check-type */
  1392.         args = make_argument_list();
  1393.         add_argument(args, make_argument(bindings->expr));
  1394.         add_argument(args,
  1395.                  make_argument(make_varref(id(p->type_temp))));
  1396.         expr = make_function_call(make_varref(id(check_type)), args);
  1397.         bindings->expr = expr;
  1398.         add_constituent(body, (struct constituent *)let);
  1399.         }
  1400.         *ptr = make_expr_constituent(make_body_expr(body));
  1401.         return TRUE;
  1402.     }
  1403.     else {
  1404.         expand_bindings(bindings);
  1405.         expand_body(let->body, FALSE);
  1406.         return FALSE;
  1407.     }
  1408.     }
  1409. }
  1410.  
  1411. static boolean expand_tlf_constituent(struct tlf_constituent **ptr,
  1412.                       boolean top_level)
  1413. {
  1414.     expand_method_for_compile((*ptr)->form);
  1415.     return FALSE;
  1416. }
  1417.  
  1418. static boolean expand_error_constituent(struct constituent **ptr)
  1419. {
  1420.     lose("Called expand on a parse tree with errors?");
  1421.     return FALSE;
  1422. }
  1423.  
  1424.  
  1425. static boolean
  1426.     expand_defnamespace_constituent(struct defnamespace_constituent **ptr,
  1427.                     boolean top_level)
  1428. {
  1429.     if (top_level)
  1430.     expand_defnamespace(*ptr);
  1431.     else
  1432.     error((*ptr)->name->line, "define %s not at top-level",
  1433.           (*ptr)->kind == constituent_DEFMODULE ? "module" : "library");
  1434.     return FALSE;
  1435. }
  1436.  
  1437. static boolean (*ConstituentExpanders[])() = {
  1438.     expand_defconst_constituent, expand_defvar_constituent,
  1439.     expand_defmethod_constituent, expand_defgeneric_constituent,
  1440.     expand_defclass_constituent, expand_expr_constituent,
  1441.     expand_local_constituent, expand_handler_constituent,
  1442.     expand_let_constituent, expand_tlf_constituent, expand_error_constituent,
  1443.     expand_defnamespace_constituent, expand_defnamespace_constituent
  1444. };
  1445.  
  1446. static boolean expand_constituent(struct constituent **ptr, boolean top_level)
  1447. {
  1448.     return (*ConstituentExpanders[(int)(*ptr)->kind])(ptr, top_level);
  1449. }
  1450.  
  1451.  
  1452. /* Block expander */
  1453.  
  1454. /* block/exit-fun forms:
  1455.  
  1456.     block (exit-fun)
  1457.       body
  1458.     end
  1459.  
  1460.     =>
  1461.  
  1462.     catch(method (temp)
  1463.             local
  1464.           method exit-fun (#rest rest)
  1465.             apply(throw, temp, rest)
  1466.           end;
  1467.         body
  1468.       end)
  1469.  
  1470.  */
  1471.  
  1472. static struct body *make_catch(int line, struct body *body,
  1473.                    struct id *exit_fun)
  1474. {
  1475.     struct symbol *temp = gensym();
  1476.     struct symbol *rest = gensym();
  1477.     struct param_list *params;
  1478.     struct arglist *args;
  1479.     struct body *new_body;
  1480.     struct method *method;
  1481.     struct local_methods *locals;
  1482.     struct expr *expr;
  1483.     struct id *name;
  1484.  
  1485.     /* Make the call to apply */
  1486.     args = make_argument_list();
  1487.     add_argument(args, make_argument(make_varref(id(sym_Throw))));
  1488.     add_argument(args, make_argument(make_varref(id(temp))));
  1489.     add_argument(args, make_argument(make_varref(id(rest))));
  1490.     expr = make_function_call(make_varref(id(sym_Apply)), args);
  1491.  
  1492.     /* Make the local method */
  1493.     params = set_rest_param(make_param_list(), id(rest));
  1494.     new_body = make_body();
  1495.     add_expr(new_body, expr);
  1496.     method = make_method_description(params, NULL, new_body);
  1497.     set_method_name(exit_fun, method);
  1498.  
  1499.     /* Make the local constituent, and add it to the outer body */
  1500.     locals = add_local_method(make_local_methods(), method);
  1501.     new_body = add_constituent(make_body(), make_local_constituent(locals));
  1502.  
  1503.     /* Chain the original body to the new body. */
  1504.     new_body = chain_bodies(new_body, body);
  1505.  
  1506.     /* Make the method arg to catch */
  1507.     params = push_param(make_param(id(temp), NULL), make_param_list());
  1508.     method = make_method_description(params, NULL, new_body);
  1509.     method->line = line;
  1510.  
  1511.     /* Make the call to catch */
  1512.     args = make_argument_list();
  1513.     add_argument(args, make_argument(make_method_ref(method)));
  1514.     name = id(sym_Catch);
  1515.     name->line = line;
  1516.     expr = make_function_call(make_varref(name), args);
  1517.  
  1518.     /* Return it. */
  1519.     return make_expr_body(expr);
  1520. }
  1521.  
  1522. /* block/exception forms:
  1523.  
  1524.    block ()
  1525.      block-body
  1526.    exception (symbol-1 :: type-1, plist-1...)
  1527.      exception-body-1
  1528.    exception (symbol-2 :: type-2, plist-2...)
  1529.      exception-body-2
  1530.    end
  1531.  
  1532.    get expanded into:
  1533.  
  1534.    block (done)
  1535.      block (do-handler)
  1536.        let handler (type-2, plist-2...)
  1537.          = method (symbol-2, ignore)
  1538.          do-handler(method () exception-body-2 end)
  1539.        end;
  1540.        let handler (type-1, plist-1...)
  1541.          = method (symbol-1, ignore)
  1542.          do-handler(method () exception-body-1 end)
  1543.        end;
  1544.        let (#rest results) = block-body;
  1545.        apply(done, results)
  1546.      end()
  1547.    end
  1548.  
  1549.  */
  1550.  
  1551. static struct body *make_handler_case(int line, struct body *block_body,
  1552.                       struct exception_clause *clauses)
  1553. {
  1554.     struct symbol *done = gensym();
  1555.     struct symbol *do_handler = gensym();
  1556.     struct symbol *results = gensym();
  1557.     struct exception_clause *next;
  1558.     struct expr *expr;
  1559.     struct param_list *params;
  1560.     struct arglist *args;
  1561.     struct method *method;
  1562.     struct body *handler_body;
  1563.     struct body *body = make_body();
  1564.     struct body *clause_body;
  1565.     
  1566.     while (clauses != NULL) {
  1567.     /* Wrap the exception body in a method */
  1568.     params = make_param_list();
  1569.     method = make_method_description(params, NULL, clauses->body);
  1570.  
  1571.     /* Make the handler method's body */
  1572.     args = make_argument_list();
  1573.     add_argument(args, make_argument(make_method_ref(method)));
  1574.     handler_body = make_body();
  1575.     add_expr(handler_body,
  1576.          make_function_call(make_varref(id(do_handler)), args));
  1577.  
  1578.     /* And make the handler method itself. */
  1579.     params = make_param_list();
  1580.     push_param(make_param(id(gensym()), NULL), params);
  1581.     if (clauses->condition)
  1582.         push_param(make_param(clauses->condition, NULL), params);
  1583.     else
  1584.         push_param(make_param(id(gensym()), NULL), params);
  1585.     method = make_method_description(params, NULL, handler_body);
  1586.  
  1587.     /* Add the handler to the body. */
  1588.     clause_body = make_body();
  1589.     add_constituent(clause_body,
  1590.             make_handler(clauses->type,
  1591.                      make_method_ref(method),
  1592.                      clauses->plist));
  1593.     body = chain_bodies(clause_body, body);
  1594.  
  1595.     /* Advance to the next clause. */
  1596.     next = clauses->next;
  1597.     free(clauses);
  1598.     clauses = next;
  1599.     }
  1600.     
  1601.     /* Invoke the block-body for multiple values. */
  1602.     params = set_rest_param(make_param_list(), id(results));
  1603.     add_constituent(body,
  1604.             make_let(make_bindings(params,
  1605.                        make_body_expr(block_body))));
  1606.  
  1607.     /* apply those results to the done exit function. */
  1608.     args = make_argument_list();
  1609.     args = add_argument(args, make_argument(make_varref(id(done))));
  1610.     args = add_argument(args, make_argument(make_varref(id(results))));
  1611.     expr = make_function_call(make_varref(id(sym_Apply)), args);
  1612.     add_expr(body, expr);
  1613.  
  1614.     /* make the do-handler block */
  1615.     expr = make_block(line, id(do_handler), body, NULL);
  1616.  
  1617.     /* Make a function call out of it. */
  1618.     expr = make_function_call(expr, make_argument_list());
  1619.  
  1620.     /* make the done block. */
  1621.     expr = make_block(line, id(done), make_expr_body(expr), NULL);
  1622.  
  1623.     /* And return it as a body. */
  1624.     return make_expr_body(expr);
  1625. }
  1626.  
  1627. static struct body *make_unwind_protect(struct body *body,struct body *cleanup)
  1628. {
  1629.     struct method *body_method
  1630.     = make_method_description(make_param_list(), NULL, body);
  1631.     struct method *cleanup_method
  1632.     = make_method_description(make_param_list(), NULL, cleanup);
  1633.     struct argument *body_arg
  1634.     = make_argument(make_method_ref(body_method));
  1635.     struct argument *cleanup_arg
  1636.     = make_argument(make_method_ref(cleanup_method));
  1637.     struct arglist *args
  1638.     = add_argument(add_argument(make_argument_list(), body_arg),
  1639.                cleanup_arg);
  1640.     struct expr *expr
  1641.     = make_function_call(make_varref(id(sym_Uwp)), args);
  1642.  
  1643.     return make_expr_body(expr);
  1644. }
  1645.  
  1646. static boolean expand_block_expr(struct expr **ptr)
  1647. {
  1648.     struct block_expr *e = (struct block_expr *)*ptr;
  1649.     struct body *body = e->body;
  1650.  
  1651.     if (ParseOnly) {
  1652.     if (e->inner) {
  1653.         body = make_handler_case(e->line, body, e->inner);
  1654.         e->inner = NULL;
  1655.     }
  1656.     if (e->outer) {
  1657.         /* There can only be an outer if there is also a cleanup */
  1658.         struct block_epilog *epilog
  1659.         = make_block_epilog(NULL, e->cleanup, NULL);
  1660.         struct expr *new = make_block(e->line, NULL, body, epilog);
  1661.  
  1662.         e->cleanup = NULL;
  1663.         add_expr(body = make_body(), new);
  1664.         body = make_handler_case(e->line, body, e->outer);
  1665.         e->outer = NULL;
  1666.     }
  1667.     if (e->exit_fun || e->cleanup) {
  1668.         e->body = body;
  1669.         expand_body(e->body, FALSE);
  1670.         if (e->cleanup)
  1671.         expand_body(e->cleanup, FALSE);
  1672.         return FALSE;
  1673.     }
  1674.     else {
  1675.         *ptr = make_body_expr(body);
  1676.         free(e);
  1677.         return TRUE;
  1678.     }
  1679.     }
  1680.     else {
  1681.     if (e->inner)
  1682.         body = make_handler_case(e->line, body, e->inner);
  1683.     if (e->cleanup)
  1684.         body = make_unwind_protect(body, e->cleanup);
  1685.     if (e->outer)
  1686.         body = make_handler_case(e->line, body, e->outer);
  1687.     if (e->exit_fun)
  1688.         body = make_catch(e->line, body, e->exit_fun);
  1689.  
  1690.     *ptr = make_body_expr(body);
  1691.  
  1692.     free(e);
  1693.  
  1694.     return TRUE;
  1695.     }
  1696. }
  1697.  
  1698.  
  1699. /* Case expander */
  1700.  
  1701. static struct expr *make_case_condition(struct condition *conditions)
  1702. {
  1703.     struct expr *cond = conditions->cond;
  1704.  
  1705.     if (conditions->next) {
  1706.     struct body *true_body
  1707.         = make_expr_body(make_literal_ref(make_true_literal()));
  1708.     struct body *rest_body
  1709.         = make_expr_body(make_case_condition(conditions->next));
  1710.  
  1711.     free(conditions);
  1712.  
  1713.     return make_if(cond, true_body, make_else(0, rest_body));
  1714.     }
  1715.     else {
  1716.     free(conditions);
  1717.     return cond;
  1718.     }
  1719. }
  1720.  
  1721. static struct expr *expand_case_body(struct condition_body *body)
  1722. {
  1723.     if (body) {
  1724.     struct condition_clause *clause = body->clause;
  1725.  
  1726.     if (clause->conditions) {
  1727.         struct expr *cond = make_case_condition(clause->conditions);
  1728.         struct expr *rest = expand_case_body(body->next);
  1729.     
  1730.         free(body);
  1731.  
  1732.         return make_if(cond, clause->body,
  1733.                make_else(0, make_expr_body(rest)));
  1734.     }
  1735.     else {
  1736.         free(body);
  1737.         return make_body_expr(clause->body);
  1738.     }
  1739.     }
  1740.     else
  1741.     return make_literal_ref(make_false_literal());
  1742. }
  1743.  
  1744. static boolean expand_case_expr(struct expr **ptr)
  1745. {
  1746.     struct case_expr *e = (struct case_expr *)*ptr;
  1747.  
  1748.     *ptr = expand_case_body(e->body);
  1749.  
  1750.     free(e);
  1751.  
  1752.     return TRUE;
  1753. }
  1754.  
  1755.  
  1756. /* For expander */
  1757.  
  1758. /* For loops expand into a body of code structured as follows:
  1759.  
  1760.    let temps;                <- outer body
  1761.    loop (repeat)
  1762.      let =/then & from vars;        <- middle body
  1763.      unless (implied-end-tests)        <- tests
  1764.        let in vars;            <- inner body
  1765.        unless (explicit-end-test)    <- until clause
  1766.          body;                <- step body
  1767.      steps;
  1768.      repeat
  1769.        end
  1770.      end
  1771.      finally
  1772.    end
  1773.  
  1774. */         
  1775.  
  1776. struct for_info {
  1777.     struct body *outer_body;
  1778.     struct body *middle_body;
  1779.     struct expr *first_test;
  1780.     struct binop_series *more_tests;
  1781.     struct body *inner_body;
  1782.     struct body *step_body;
  1783. };
  1784.  
  1785. static void cache_types(struct param_list *params, struct for_info *info)
  1786. {
  1787.     struct param *param;
  1788.  
  1789.     for (param = params->required_params; param != NULL; param = param->next) {
  1790.     if (param->type) {
  1791.         param->type_temp = gensym();
  1792.         bind_temp(info->outer_body, id(param->type_temp), param->type);
  1793.         param->type = NULL;
  1794.     }
  1795.     }
  1796. }
  1797.  
  1798. static void add_set(struct body *body, struct id *id, struct expr *expr)
  1799. {
  1800.     add_expr(body, make_varset(id, expr));
  1801. }
  1802.  
  1803. static void grovel_equal_then_for_clause(struct equal_then_for_clause *clause,
  1804.                      struct for_info *info)
  1805. {
  1806.     struct param_list *params = clause->vars;
  1807.     struct param *init_params_head = NULL;
  1808.     struct param **init_params_tail = &init_params_head;
  1809.     struct param_list *step_params = make_param_list();
  1810.     struct param *step_params_head = NULL;
  1811.     struct param **step_params_tail = &step_params_head;
  1812.     struct param *param, *next;
  1813.  
  1814.     bind_params(info->outer_body, params, clause->equal);
  1815.     bind_params(info->step_body, step_params, clause->then);
  1816.  
  1817.     for (param = params->required_params; param != NULL; param = next) {
  1818.     struct symbol *temp1 = gensym();
  1819.     struct symbol *temp2 = gensym();
  1820.     struct param *init_param = make_param(id(temp1), NULL);
  1821.     struct param *step_param = make_param(id(temp2), NULL);
  1822.  
  1823.     *init_params_tail = init_param;
  1824.     init_params_tail = &init_param->next;
  1825.     *step_params_tail = step_param;
  1826.     step_params_tail = &step_param->next;
  1827.  
  1828.     next = param->next;
  1829.     bind_param(info->middle_body, param, make_varref(id(temp1)));
  1830.     add_set(info->step_body, id(temp1), make_varref(id(temp2)));
  1831.     }
  1832.     params->required_params = init_params_head;
  1833.     step_params->required_params = step_params_head;
  1834.  
  1835.     if (params->rest_param) {
  1836.     struct id *rest = params->rest_param;
  1837.     struct symbol *temp1 = gensym();
  1838.     struct symbol *temp2 = gensym();
  1839.  
  1840.     params->rest_param = id(temp1);
  1841.     step_params->rest_param = id(temp2);
  1842.  
  1843.     bind_temp(info->middle_body, rest, make_varref(id(temp1)));
  1844.     add_set(info->step_body, id(temp1), make_varref(id(temp2)));
  1845.     }
  1846. }
  1847.  
  1848. static void add_test(struct expr *test, struct for_info *info)
  1849. {
  1850.     if (info->more_tests)
  1851.     info->more_tests
  1852.         = add_binop(info->more_tests, make_binop(id(sym_Or)), test);
  1853.     else {
  1854.     info->more_tests = make_binop_series();
  1855.     info->first_test = test;
  1856.     }
  1857. }
  1858.  
  1859. static void grovel_in_for_clause(struct in_for_clause *clause,
  1860.                  struct for_info *info)
  1861. {
  1862.     struct param *var = clause->vars->required_params;
  1863.     struct param *keyed_by = var->next;
  1864.     struct symbol *coll = gensym();
  1865.     struct symbol *state = gensym();
  1866.     struct symbol *limit = gensym();
  1867.     struct symbol *next = gensym();
  1868.     struct symbol *done = gensym();
  1869.     struct symbol *curkey = gensym();
  1870.     struct symbol *curel = gensym();
  1871.     struct param_list *params = make_param_list();
  1872.     struct expr *expr;
  1873.     struct arglist *args;
  1874.     struct bindings *bindings;
  1875.  
  1876.     /* Bind the collection. */
  1877.     bind_temp(info->outer_body, id(coll), clause->collection);
  1878.  
  1879.     /* Bind the iteration protocol */
  1880.     push_param(make_param(id(curel), NULL), params);
  1881.     push_param(make_param(id(curkey), NULL), params);
  1882.     push_param(make_param(id(done), NULL), params);
  1883.     push_param(make_param(id(next), NULL), params);
  1884.     push_param(make_param(id(limit), NULL), params);
  1885.     push_param(make_param(id(state), NULL), params);
  1886.     args = make_argument_list();
  1887.     add_argument(args, make_argument(make_varref(id(coll))));
  1888.     expr = make_varref(id(sym_ForwardIterationProtocol));
  1889.     bindings = make_bindings(params, make_function_call(expr, args));
  1890.     add_constituent(info->outer_body, make_let(bindings));
  1891.  
  1892.     /* Add the test for being done with the collection. */
  1893.     args = make_argument_list();
  1894.     add_argument(args, make_argument(make_varref(id(coll))));
  1895.     add_argument(args, make_argument(make_varref(id(state))));
  1896.     add_argument(args, make_argument(make_varref(id(limit))));
  1897.     add_test(make_function_call(make_varref(id(done)), args), info);
  1898.  
  1899.     /* Bind the users variable to the current element in the inner body. */
  1900.     args = make_argument_list();
  1901.     add_argument(args, make_argument(make_varref(id(coll))));
  1902.     add_argument(args, make_argument(make_varref(id(state))));
  1903.     expr = make_function_call(make_varref(id(curel)), args);
  1904.     bind_param(info->inner_body, var, expr);
  1905.  
  1906.     /* Bind the keyed_by variable if supplied. */
  1907.     if (keyed_by) {
  1908.     args = make_argument_list();
  1909.     add_argument(args, make_argument(make_varref(id(coll))));
  1910.     add_argument(args, make_argument(make_varref(id(state))));
  1911.     expr = make_function_call(make_varref(id(curkey)), args);
  1912.     bind_param(info->inner_body, keyed_by, expr);
  1913.     }
  1914.  
  1915.     /* Free the clauses param_list, because we've extracted the two params */
  1916.     /* from it. */
  1917.     free(clause->vars);
  1918.  
  1919.     /* Advance the state in the steps. */
  1920.     args = make_argument_list();
  1921.     add_argument(args, make_argument(make_varref(id(coll))));
  1922.     add_argument(args, make_argument(make_varref(id(state))));
  1923.     expr = make_function_call(make_varref(id(next)), args);
  1924.     add_set(info->step_body, id(state), expr);
  1925. }
  1926.  
  1927. static void grovel_from_for_clause(struct from_for_clause *clause,
  1928.                    struct for_info *info)
  1929. {
  1930.     struct symbol *temp = gensym();
  1931.     struct symbol *bound = NULL;
  1932.     struct symbol *by_temp = NULL;
  1933.     struct expr *by = NULL;
  1934.     struct arglist *args;
  1935.     struct expr *expr;
  1936.  
  1937.     /* Bind the start in the outer body. */
  1938.     bind_temp(info->outer_body, id(temp), clause->from);
  1939.  
  1940.     /* Bind the bound if there is one. */
  1941.     if (clause->to) {
  1942.     bound = gensym();
  1943.     bind_temp(info->outer_body, id(bound), clause->to);
  1944.     }
  1945.  
  1946.     /* Figure out what by should be, binding it if necessary. */
  1947.     if (clause->by) {
  1948.     by_temp = gensym();
  1949.     bind_temp(info->outer_body, id(by_temp), clause->by);
  1950.     by = make_varref(id(by_temp));
  1951.     }
  1952.     else if (clause->to_kind == to_ABOVE)
  1953.     by = make_literal_ref(make_integer_literal(-1));
  1954.     else
  1955.     by = make_literal_ref(make_integer_literal(1));
  1956.     
  1957.     /* Bind the user variable in the middle body. */
  1958.     bind_params(info->middle_body, clause->vars, make_varref(id(temp)));
  1959.  
  1960.     /* Add the end test. */
  1961.     switch (clause->to_kind) {
  1962.       case to_TO:
  1963.     if (by_temp) {
  1964.         struct expr *when_negative, *when_positive;
  1965.  
  1966.         args = make_argument_list();
  1967.         add_argument(args, make_argument(make_varref(id(temp))));
  1968.         add_argument(args, make_argument(make_varref(id(bound))));
  1969.         when_negative
  1970.         = make_function_call(make_varref(id(sym_Less)), args);
  1971.  
  1972.         args = make_argument_list();
  1973.         add_argument(args, make_argument(make_varref(id(bound))));
  1974.         add_argument(args, make_argument(make_varref(id(temp))));
  1975.         when_positive
  1976.         = make_function_call(make_varref(id(sym_Less)), args);
  1977.  
  1978.         args = make_argument_list();
  1979.         add_argument(args, make_argument(make_varref(id(by_temp))));
  1980.         expr = make_function_call(make_varref(id(sym_NegativeP)),
  1981.                       args);
  1982.  
  1983.         add_test(make_if(expr, make_expr_body(when_negative),
  1984.                  make_else(0, make_expr_body(when_positive))),
  1985.              info);
  1986.     }
  1987.     else {
  1988.         args = make_argument_list();
  1989.         add_argument(args, make_argument(make_varref(id(bound))));
  1990.         add_argument(args, make_argument(make_varref(id(temp))));
  1991.         add_test(make_function_call(make_varref(id(sym_Less)), args),
  1992.              info);
  1993.     }
  1994.     break;
  1995.  
  1996.       case to_ABOVE:
  1997.     args = make_argument_list();
  1998.     add_argument(args, make_argument(make_varref(id(temp))));
  1999.     add_argument(args, make_argument(make_varref(id(bound))));
  2000.     add_test(make_function_call(make_varref(id(sym_LessEqual)), args),
  2001.          info);
  2002.     break;
  2003.  
  2004.       case to_BELOW:
  2005.     args = make_argument_list();
  2006.     add_argument(args, make_argument(make_varref(id(bound))));
  2007.     add_argument(args, make_argument(make_varref(id(temp))));
  2008.     add_test(make_function_call(make_varref(id(sym_LessEqual)), args),
  2009.          info);
  2010.     break;
  2011.  
  2012.       case to_UNBOUNDED:
  2013.     break;
  2014.  
  2015.       default:
  2016.     lose("Bogus to kind in from for clause"); 
  2017.     }
  2018.  
  2019.     /* Advance the count by by */
  2020.     args = make_argument_list();
  2021.     add_argument(args, make_argument(make_varref(id(temp))));
  2022.     add_argument(args, make_argument(by));
  2023.     expr = make_function_call(make_varref(id(sym_Plus)), args);
  2024.     add_set(info->step_body, id(temp), expr);
  2025. }
  2026.  
  2027. static void (*ForClauseGrovelers[])() = {
  2028.     grovel_equal_then_for_clause,
  2029.     grovel_in_for_clause,
  2030.     grovel_from_for_clause
  2031. };
  2032.  
  2033. static boolean expand_for_expr(struct expr **ptr)
  2034. {
  2035.     struct for_expr *e = (struct for_expr *)*ptr;
  2036.     struct for_info info;
  2037.     struct repeat_expr *repeat;
  2038.     struct expr *expr;
  2039.     struct loop_expr *loop;
  2040.     struct for_clause *clause, *next;
  2041.  
  2042.     info.outer_body = make_body();
  2043.     info.middle_body = make_body();
  2044.     info.first_test = NULL;
  2045.     info.more_tests = NULL;
  2046.     info.inner_body = make_body();
  2047.     info.step_body = e->body;
  2048.  
  2049.     /* Grovel the clauses. */
  2050.     for (clause = e->clauses; clause != NULL; clause = next) {
  2051.     cache_types(clause->vars, &info);
  2052.     (*ForClauseGrovelers[(int)clause->kind])(clause, &info);
  2053.     next = clause->next;
  2054.     free(clause);
  2055.     }
  2056.  
  2057.     /* Add the call to repeat to the step body. */
  2058.     repeat = (struct repeat_expr *)make_repeat();
  2059.     add_expr(info.step_body, (struct expr *)repeat);
  2060.  
  2061.     /* Wrap the step body with the ``if (end-test) ...'' (if necessary) and */
  2062.     /* add it to the inner body. */
  2063.     if (e->until)
  2064.     expr = make_if(e->until, NULL, make_else(0, info.step_body));
  2065.     else
  2066.     expr = make_body_expr(info.step_body);
  2067.     add_expr(info.inner_body, expr);
  2068.  
  2069.     /* Wrap the inner body with the implicit end tests and add it to the */
  2070.     /* middle body */
  2071.     if (info.more_tests)
  2072.     expr = make_if(make_binop_series_expr(info.first_test,info.more_tests),
  2073.                NULL,
  2074.                make_else(0, info.inner_body));
  2075.     else
  2076.     expr = make_body_expr(info.inner_body);
  2077.     add_expr(info.middle_body, expr);
  2078.  
  2079.     /* Add the final part to the middle body */
  2080.     if (e->finally)
  2081.     add_expr(info.middle_body, make_body_expr(e->finally));
  2082.  
  2083.     /* Make the loop, and add it to the outer body. */
  2084.     loop = (struct loop_expr *)make_loop(info.middle_body);
  2085.     repeat->loop = loop;
  2086.     add_expr(info.outer_body, (struct expr *)loop);
  2087.  
  2088.     /* Change this expression into the outer body. */
  2089.     *ptr = make_body_expr(info.outer_body);
  2090.  
  2091.     /* Free the loop expression now that we are done with it. */
  2092.     free(e);
  2093.  
  2094.     return TRUE;
  2095. }
  2096.  
  2097.  
  2098. /* Select expander */
  2099.  
  2100. static struct expr
  2101.     *make_select_condition(struct condition *conditions,
  2102.                struct symbol *val, struct symbol *by)
  2103. {
  2104.     struct arglist *args
  2105.     = add_argument(add_argument(make_argument_list(),
  2106.                     make_argument(make_varref(id(val)))),
  2107.                make_argument(conditions->cond));
  2108.     struct expr *cond = make_function_call(make_varref(id(by)), args);
  2109.  
  2110.     if (conditions->next) {
  2111.     struct body *true_body
  2112.         = make_expr_body(make_literal_ref(make_true_literal()));
  2113.     struct body *rest_body
  2114.         = make_expr_body(make_select_condition(conditions->next, val, by));
  2115.  
  2116.     free(conditions);
  2117.  
  2118.     return make_if(cond, true_body, make_else(0, rest_body));
  2119.     }
  2120.     else {
  2121.     free(conditions);
  2122.     return cond;
  2123.     }
  2124. }
  2125.  
  2126. static struct expr *expand_select_body(struct condition_body *body,
  2127.                        struct symbol *val, struct symbol *by)
  2128. {
  2129.     if (body) {
  2130.     struct condition_clause *clause = body->clause;
  2131.  
  2132.     if (clause->conditions) {
  2133.         struct expr *cond
  2134.         = make_select_condition(clause->conditions, val, by);
  2135.         struct expr *rest = expand_select_body(body->next, val, by);
  2136.     
  2137.         free(body);
  2138.  
  2139.         return make_if(cond, clause->body,
  2140.                make_else(0, make_expr_body(rest)));
  2141.     }
  2142.     else {
  2143.         free(body);
  2144.         return make_body_expr(clause->body);
  2145.     }
  2146.     }
  2147.     else {
  2148.     struct expr *expr
  2149.         = make_literal_ref(make_string_literal("fell through select"));
  2150.     struct arglist *args
  2151.         = add_argument(make_argument_list(), make_argument(expr));
  2152.  
  2153.     return make_function_call(make_varref(id(sym_Error)), args);
  2154.     }
  2155. }
  2156.  
  2157. static boolean expand_select_expr(struct expr **ptr)
  2158. {
  2159.     struct select_expr *e = (struct select_expr *)*ptr;
  2160.     struct symbol *valtemp = gensym();
  2161.     struct symbol *bytemp = e->by ? gensym() : sym_Eq;
  2162.     struct body *body = make_body();
  2163.  
  2164.     bind_temp(body, id(valtemp), e->expr);
  2165.     if (e->by)
  2166.     bind_temp(body, id(bytemp), e->by);
  2167.  
  2168.     add_expr(body, expand_select_body(e->body, valtemp, bytemp));
  2169.  
  2170.     *ptr = make_body_expr(body);
  2171.  
  2172.     free(e);
  2173.  
  2174.     return TRUE;
  2175. }
  2176.  
  2177.  
  2178. /* Binop series expander */
  2179.  
  2180. static struct expr *make_binary_fn_call(struct id *op, struct expr *left,
  2181.                     struct expr *right)
  2182. {
  2183.     struct arglist *args
  2184.     = add_argument(add_argument(make_argument_list(),
  2185.                     make_argument(left)),
  2186.                make_argument(right));
  2187.     return make_function_call(make_varref(op), args);
  2188. }
  2189.  
  2190. static boolean expand_binop_series_expr(struct expr **ptr)
  2191. {
  2192.     struct binop_series_expr *e = (struct binop_series_expr *)*ptr;
  2193.     struct binop *stack = NULL;
  2194.     struct expr *left = e->first_operand;
  2195.     struct binop *op = e->first_binop;
  2196.     struct expr *right = op->operand;
  2197.     struct binop *next = op->next;
  2198.  
  2199.     while (next) {
  2200.     if (op->left_assoc
  2201.           ? (op->precedence >= next->precedence)
  2202.           : (op->precedence > next->precedence)) {
  2203.         /* We want to reduce left.op.right */
  2204.         struct expr *new = make_binary_fn_call(op->op, left, right);
  2205.         free(op);
  2206.         if (stack) {
  2207.         /* We want to reduce into right and pop the stack. */
  2208.         right = new;
  2209.         op = stack;
  2210.         stack = stack->next;
  2211.         left = op->operand;
  2212.         }
  2213.         else {
  2214.         /* We want to reduce into left and pop next. */
  2215.         left = new;
  2216.         op = next;
  2217.         right = op->operand;
  2218.         next = next->next;
  2219.         }
  2220.     }
  2221.     else {
  2222.         /* We want to shift this onto the stack. */
  2223.         op->operand = left;
  2224.         op->next = stack;
  2225.         stack = op;
  2226.         left = right;
  2227.         op = next;
  2228.         right = op->operand;
  2229.         next = next->next;
  2230.     }
  2231.     }
  2232.     while (1) {
  2233.     right = make_binary_fn_call(op->op, left, right);
  2234.     free(op);
  2235.     if (stack == NULL)
  2236.         break;
  2237.     op = stack;
  2238.     left = op->operand;
  2239.     stack = stack->next;
  2240.     }
  2241.  
  2242.     free(e);
  2243.  
  2244.     *ptr = right;
  2245.  
  2246.     return TRUE;
  2247. }
  2248.  
  2249.  
  2250. /* Simple expression expanders. */
  2251.  
  2252. static boolean expand_varref_expr(struct varref_expr **ptr)
  2253. {
  2254.     /* Nothing to do. */
  2255.     return FALSE;
  2256. }
  2257.  
  2258. static boolean expand_literal_expr(struct literal_expr **ptr)
  2259. {
  2260.     /* Nothing to do. */
  2261.     return FALSE;
  2262. }
  2263.  
  2264. static boolean expand_call_expr(struct call_expr **ptr)
  2265. {
  2266.     struct call_expr *e = *ptr;
  2267.     struct argument *arg;
  2268.  
  2269.     if (e->info && e->info->srctran) {
  2270.     if (e->func->kind != expr_VARREF)
  2271.         lose("Source-transforming a call where the function "
  2272.          "isn't a varref?");
  2273.     if ((*e->info->srctran)(ptr))
  2274.         return TRUE;
  2275.     }
  2276.  
  2277.     expand_expr(&e->func);
  2278.     for (arg = e->args; arg != NULL; arg = arg->next)
  2279.     expand_expr(&arg->expr);
  2280.     return FALSE;
  2281. }
  2282.  
  2283. static boolean expand_dot_expr(struct expr **ptr)
  2284. {
  2285.     struct dot_expr *e = (struct dot_expr *)*ptr;
  2286.  
  2287.     expand_expr(&e->arg);
  2288.     expand_expr(&e->func);
  2289.  
  2290.     return FALSE;
  2291. }
  2292.  
  2293. static struct literal *extract_literal(struct body *body)
  2294. {
  2295.     struct expr *expr;
  2296.  
  2297.     if (body->head == NULL)
  2298.     return make_false_literal();
  2299.     if (body->head->next != NULL)
  2300.     return NULL;
  2301.     if (body->head->kind != constituent_EXPR)
  2302.     return NULL;
  2303.     expr = ((struct expr_constituent *)body->head)->expr;
  2304.     if (expr->kind != expr_LITERAL)
  2305.     return NULL;
  2306.     else
  2307.     return ((struct literal_expr *)expr)->lit;
  2308. }
  2309.  
  2310. static boolean expand_if_expr(struct expr **ptr)
  2311. {
  2312.     struct if_expr *e = *(struct if_expr **)ptr;
  2313.  
  2314.     expand_expr(&e->cond);
  2315.  
  2316.     if (!ParseOnly && e->cond->kind == expr_LITERAL) {
  2317.     struct literal *lit = ((struct literal_expr *)e->cond)->lit;
  2318.     if (lit->kind == literal_FALSE) {
  2319.         free_body(e->consequent);
  2320.         *ptr = make_body_expr(e->alternate);
  2321.     }
  2322.     else {
  2323.         *ptr = make_body_expr(e->consequent);
  2324.         free_body(e->alternate);
  2325.     }
  2326.     free_expr(e->cond);
  2327.     free(e);
  2328.     return TRUE;
  2329.     }
  2330.  
  2331.     expand_body(e->consequent, FALSE);
  2332.     expand_body(e->alternate, FALSE);
  2333.  
  2334.     if (!ParseOnly && e->cond->kind == expr_IF) {
  2335.     struct if_expr *inner = (struct if_expr *)e->cond;
  2336.     struct literal *inner_consequent = extract_literal(inner->consequent);
  2337.     struct literal *inner_alternate = extract_literal(inner->alternate);
  2338.  
  2339.     if (inner_consequent && inner_alternate) {
  2340.         if (inner_consequent->kind != literal_FALSE)
  2341.         if (inner_alternate->kind != literal_FALSE) {
  2342.             /* They are both true.  So no matter what we are going */
  2343.             /* to only do the consequent.  But we need to eval the */
  2344.             /* condition none the less. */
  2345.             struct constituent *c = make_expr_constituent(inner->cond);
  2346.             c->next = e->consequent->head;
  2347.             e->consequent->head = c;
  2348.             if (c->next == NULL)
  2349.             e->consequent->tail = &c->next;
  2350.             free_body(e->alternate);
  2351.             *ptr = make_body_expr(e->consequent);
  2352.             free(e);
  2353.         }
  2354.         else {
  2355.             /* The inner consequent is true and the inner alternate */
  2356.             /* is false.  So we just use the inner condition. */
  2357.             e->cond = inner->cond;
  2358.         }
  2359.         else
  2360.         if (inner_alternate->kind != literal_FALSE) {
  2361.             /* The inner consequent is false and the inner alternate */
  2362.             /* is true.  Therefore, we use the inner condition but */
  2363.             /* which the consequent and alternate. */
  2364.             struct body *temp = e->consequent;
  2365.             e->cond = inner->cond;
  2366.             e->consequent = e->alternate;
  2367.             e->alternate = temp;
  2368.         }
  2369.         else {
  2370.             /* Both are false, so we always do the alternate. */
  2371.             struct constituent *c = make_expr_constituent(inner->cond);
  2372.             c->next = e->alternate->head;
  2373.             e->alternate->head = c;
  2374.             if (c->next == NULL)
  2375.             e->alternate->tail = &c->next;
  2376.             free_body(e->consequent);
  2377.             *ptr = make_body_expr(e->alternate);
  2378.             free(e);
  2379.         }
  2380.         free_body(inner->consequent);
  2381.         free_body(inner->alternate);
  2382.         free(inner);
  2383.         return FALSE;
  2384.     }
  2385.     else {
  2386.         struct body *consequent = dup_body(e->consequent);
  2387.         struct body *alternate = dup_body(e->alternate);
  2388.         if (consequent != NULL && alternate != NULL) {
  2389.         e->cond = inner->cond;
  2390.         e->consequent
  2391.             = make_expr_body(make_if(make_body_expr(inner->consequent),
  2392.                          e->consequent,
  2393.                          make_else(0, e->alternate)));
  2394.         e->alternate
  2395.             = make_expr_body(make_if(make_body_expr(inner->alternate),
  2396.                          consequent,
  2397.                          make_else(0, alternate)));
  2398.         free(inner);
  2399.  
  2400.         return TRUE;
  2401.         }
  2402.         else {
  2403.         if (consequent)
  2404.             free_body(consequent);
  2405.         if (alternate)
  2406.             free_body(alternate);
  2407.         return FALSE;
  2408.         }
  2409.     }
  2410.     }
  2411.     else
  2412.     return FALSE;
  2413. }
  2414.  
  2415. static boolean expand_varset_expr(struct varset_expr **ptr)
  2416. {
  2417.     struct varset_expr *e = *ptr;
  2418.  
  2419.     expand_expr(&e->value);
  2420.  
  2421.     return FALSE;
  2422. }
  2423.  
  2424. static boolean expand_body_expr(struct body_expr **ptr)
  2425. {
  2426.     expand_body((*ptr)->body, FALSE);
  2427.     return FALSE;
  2428. }
  2429.  
  2430. static boolean expand_method_expr(struct expr **ptr)
  2431. {
  2432.     struct method_expr *e = (struct method_expr *)*ptr;
  2433.     struct method *method = e->method;
  2434.  
  2435.     if (ParseOnly) {
  2436.     expand_method_for_parse(method);
  2437.     return FALSE;
  2438.     }
  2439.     else if (method->specializers) {
  2440.     expand_method_for_compile(method);
  2441.     return FALSE;
  2442.     }
  2443.     else {
  2444.     struct body *body = make_body();
  2445.     add_method_wrap(body, method);
  2446.     add_expr(body, (struct expr *)e);
  2447.     *ptr = make_body_expr(body);
  2448.     return TRUE;
  2449.     }
  2450. }
  2451.  
  2452. static boolean expand_loop_expr(struct loop_expr **ptr)
  2453. {
  2454.     expand_body((*ptr)->body, FALSE);
  2455.     return FALSE;
  2456. }
  2457.  
  2458. static boolean expand_repeat_expr(struct repeat_expr **ptr)
  2459. {
  2460.     /* No nothing. */
  2461.     return FALSE;
  2462. }
  2463.  
  2464. static boolean expand_error_expr(struct expr **ptr)
  2465. {
  2466.     lose("Called expand on a parse tree with errors?");
  2467.     return FALSE;
  2468. }
  2469.  
  2470. static boolean (*ExpressionExpanders[])() = {
  2471.     expand_varref_expr, expand_literal_expr, expand_call_expr,
  2472.     expand_method_expr, expand_dot_expr, expand_body_expr, expand_block_expr,
  2473.     expand_case_expr, expand_if_expr, expand_for_expr, expand_select_expr,
  2474.     expand_varset_expr, expand_binop_series_expr, expand_loop_expr,
  2475.     expand_repeat_expr, expand_error_expr
  2476. };
  2477.  
  2478. static void expand_expr(struct expr **ptr)
  2479. {
  2480.     struct expr *expr;
  2481.  
  2482.     do {
  2483.     expr = *ptr;
  2484.     } while ((*ExpressionExpanders[(int)expr->kind])(ptr));
  2485. }
  2486.  
  2487.  
  2488. /* Expand */
  2489.  
  2490. static void expand_body(struct body *body, boolean top_level)
  2491. {
  2492.     struct constituent **prev, *next;
  2493.  
  2494.     if (body->head == NULL)
  2495.     body->head
  2496.         = make_expr_constituent(make_literal_ref(make_false_literal()));
  2497.  
  2498.     prev = &body->head;
  2499.     do {
  2500.     next = (*prev)->next;
  2501.     while (expand_constituent(prev, top_level))
  2502.         ;
  2503.     prev = &(*prev)->next;
  2504.     *prev = next;
  2505.     } while (next);
  2506. }
  2507.  
  2508. void expand(struct body *body)
  2509. {
  2510.     expand_body(body, TRUE);
  2511. }
  2512.  
  2513.  
  2514. /* Call src->src transforms */
  2515.  
  2516. static void free_function_ref(struct expr *expr)
  2517. {
  2518.     struct varref_expr *varref = (struct varref_expr *)expr;
  2519.  
  2520.     free(varref->var);
  2521.     free(varref);
  2522. }
  2523.  
  2524. static boolean srctran_varref_assignment(struct expr **ptr)
  2525. {
  2526.     struct call_expr *e = (struct call_expr *)*ptr;
  2527.     struct argument *args = e->args;
  2528.     struct varref_expr *varref = (struct varref_expr *)args->expr;
  2529.     struct argument *value = args->next;
  2530.  
  2531.     *ptr = make_varset(varref->var, value->expr);
  2532.  
  2533.     free(value);
  2534.     free(varref);
  2535.     free(args);
  2536.     free_function_ref(e->func);
  2537.     free(e);
  2538.  
  2539.     return TRUE;
  2540. }
  2541.  
  2542. static boolean srctran_call_assignment(struct expr **ptr)
  2543. {
  2544.     struct call_expr *e = (struct call_expr *)*ptr;
  2545.     struct argument *args = e->args;
  2546.     struct call_expr *comb = (struct call_expr *)args->expr;
  2547.     struct argument *value = args->next;
  2548.     struct body *body;
  2549.     struct symbol *temp;
  2550.  
  2551.     if (comb->func->kind != expr_VARREF)
  2552.     return FALSE;
  2553.     change_to_setter(((struct varref_expr *)comb->func)->var);
  2554.  
  2555.     temp = gensym();
  2556.     body = make_body();
  2557.     bind_temp(body, id(temp), value->expr);
  2558.  
  2559.     value->expr = make_varref(id(temp));
  2560.     value->next = comb->args;
  2561.     comb->args = value;
  2562.     add_expr(body, (struct expr *)comb);
  2563.  
  2564.     add_expr(body, make_varref(id(temp)));
  2565.  
  2566.     *ptr = make_body_expr(body);
  2567.  
  2568.     free(args);
  2569.     free_function_ref(e->func);
  2570.     free(e);
  2571.  
  2572.     return TRUE;
  2573. }
  2574.  
  2575. static boolean srctran_dot_assignment(struct expr **ptr)
  2576. {
  2577.     struct call_expr *e = (struct call_expr *)*ptr;
  2578.     struct argument *lhs = e->args;
  2579.     struct dot_expr *dot = (struct dot_expr *)lhs->expr;
  2580.     struct argument *value = lhs->next;
  2581.     struct expr *func = dot->func;
  2582.     struct arglist *args;
  2583.     struct body *body;
  2584.     struct symbol *temp;
  2585.  
  2586.     if (func->kind != expr_VARREF)
  2587.     return FALSE;
  2588.     change_to_setter(((struct varref_expr *)func)->var);
  2589.  
  2590.     temp = gensym();
  2591.     body = make_body();
  2592.     bind_temp(body, id(temp), value->expr);
  2593.  
  2594.     value->expr = make_varref(id(temp));
  2595.     args = add_argument(make_argument_list(), value);
  2596.     args = add_argument(args, make_argument(dot->arg));
  2597.     add_expr(body, make_function_call(dot->func, args));
  2598.  
  2599.     add_expr(body, make_varref(id(temp)));
  2600.  
  2601.     *ptr = make_body_expr(body);
  2602.  
  2603.     free(dot);
  2604.     free(lhs);
  2605.     free_function_ref(e->func);
  2606.     free(e);
  2607.  
  2608.     return TRUE;
  2609. }
  2610.  
  2611. static boolean srctran_assignment(struct expr **ptr)
  2612. {
  2613.     struct call_expr *e = (struct call_expr *)*ptr;
  2614.     struct argument *lhs = e->args;
  2615.  
  2616.     /* Make sure there are only two arguments. */
  2617.     if (lhs==NULL || lhs->next==NULL || lhs->next->next!=NULL) {
  2618.     struct varref_expr *func = (struct varref_expr *)e->func;
  2619.     error(func->var->line, ":= invoked with other than two arguments");
  2620.     return FALSE;
  2621.     }
  2622.  
  2623.     switch (lhs->expr->kind) {
  2624.       case expr_VARREF:
  2625.     return srctran_varref_assignment(ptr);
  2626.  
  2627.       case expr_CALL:
  2628.     return srctran_call_assignment(ptr);
  2629.  
  2630.       case expr_DOT:
  2631.     return srctran_dot_assignment(ptr);
  2632.  
  2633.       default:
  2634.     {
  2635.         struct varref_expr *func = (struct varref_expr *)e->func;
  2636.         error(func->var->line, ":= applied to non-assignable expression.");
  2637.     }
  2638.     return FALSE;
  2639.     }
  2640. }
  2641.  
  2642. static boolean srctran_and(struct expr **ptr)
  2643. {
  2644.     struct call_expr *e = (struct call_expr *)*ptr;
  2645.     struct argument *arg = e->args;
  2646.  
  2647.     if (arg == NULL) {
  2648.     *ptr = make_literal_ref(make_false_literal());
  2649.     free_function_ref(e->func);
  2650.     }
  2651.     else if (arg->next == NULL) {
  2652.     *ptr = arg->expr;
  2653.     free_function_ref(e->func);
  2654.     free(arg);
  2655.     }
  2656.     else {
  2657.     e->args = arg->next;
  2658.     *ptr = make_if(arg->expr, make_expr_body((struct expr *)e), NULL);
  2659.     free(arg);
  2660.     }
  2661.     return TRUE;
  2662. }
  2663.  
  2664. static boolean srctran_or(struct expr **ptr)
  2665. {
  2666.     struct call_expr *e = (struct call_expr *)*ptr;
  2667.     struct argument *arg = e->args;
  2668.  
  2669.     if (arg == NULL) {
  2670.     *ptr = make_literal_ref(make_true_literal());
  2671.     free_function_ref(e->func);
  2672.     }
  2673.     else if (arg->next == NULL) {
  2674.     *ptr = arg->expr;
  2675.     free_function_ref(e->func);
  2676.     free(arg);
  2677.     }
  2678.     else {
  2679.     struct symbol *temp = gensym();
  2680.     struct body *body = make_body();
  2681.  
  2682.     e->args = arg->next;
  2683.     bind_temp(body, id(temp), arg->expr);
  2684.     add_expr(body,
  2685.          make_if(make_varref(id(temp)),
  2686.              make_expr_body(make_varref(id(temp))),
  2687.              make_else(0, make_expr_body((struct expr *)e))));
  2688.     *ptr = make_body_expr(body);
  2689.     free(arg);
  2690.     }
  2691.  
  2692.     return TRUE;
  2693. }
  2694.  
  2695.  
  2696.  
  2697. /* Initialization stuff. */
  2698.  
  2699. static void set_srctran(char *name, boolean (*srctran)(), boolean internal)
  2700. {
  2701.     struct id *identifier = id(symbol(name));
  2702.     struct function_info *info;
  2703.  
  2704.     identifier->internal = internal;
  2705.     info = lookup_function_info(identifier, TRUE);
  2706.     info->srctran = srctran;
  2707.  
  2708.     free(identifier);
  2709. }
  2710.  
  2711. void init_expand(void)
  2712. {
  2713.     set_srctran(":=", srctran_assignment, TRUE);
  2714.     set_srctran(":=", srctran_assignment, FALSE);
  2715.     set_srctran("&", srctran_and, TRUE);
  2716.     set_srctran("&", srctran_and, FALSE);
  2717.     set_srctran("|", srctran_or, TRUE);
  2718.     set_srctran("|", srctran_or, FALSE);
  2719. }
  2720.